home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 095 / 151b_src.arc / RBBSSUB2.BAS < prev    next >
BASIC Source File  |  1987-06-07  |  152KB  |  3,820 lines
  1. ' $linesize:132
  2. ' $title: 'RBBSSUB2.BAS CPC15-1B, Copyright 1986 & 87 by D. Thomas Mack'
  3. '  Copyright 1987 by D. Thomas Mack, all rights reserved.
  4. '  Name ...............: RBBSSUB2.BAS
  5. '  Written by .........: D. Thomas Mack
  6. '  First Released .....: June 29, 1986
  7. '  Subsequent Releases.: September 28, 1986, March 15, 1987, June 7, 1987
  8. '  Copyright ..........: 1986, 1987
  9. '  Purpose.............: The Remote Bulletin Board System for the IBM PC,
  10. '                        RBBS-PC.BAS utilizes a lot of common subroutines.
  11. '                        Those that do not reqpure error trapping are
  12. '                        incorporated within RBBSSUB2.BAS as separately call-
  13. '                        able subroutines in order to free up as much code as
  14. '                        possible within the 64K code segment used by
  15. '                        RBBS-PC.BAS.
  16. '  Parameters..........: Most parameters are passed via a COMMON statement.
  17. '
  18. ' Subroutine  Line               Function of Subroutine
  19. '   Name     Number
  20. '  ALLCAPS    58060   Convert a string to all upper case characters
  21. '  ALLCAPSD   58065   Convert a dimensioned string to all upper case characters
  22. '  AMORPM     41500   Calculate the current time as AM or PM
  23. '  BADCHAR      455   Check user name for invalid characters
  24. '  BADFILE    20741   Check for system crash attempt with bad device name
  25. '  BADNAME    20235   Check for system crash attempt with bad file name
  26. '  BRKFNAME   20282   Break a file name into it's component parts
  27. '  BUFFILE    58400   Write a file to the user quickly
  28. '  BUFSTRNG   58300   Write a string with imbedded CR/LF to the user quickly
  29. '  CALLOPT    58090   Set prompts based on the user's security
  30. '  CARRIER    42000   Test for Carrier present
  31. '  CHECKTIM   58070   Test to insure that users don't exceed their time
  32. '  CHKNARY    58180   Check for the occurance of a string in an array
  33. '  CHKNEWBUL  58110   Check for new bulletins based on their file creation date
  34. '  COMMINFO   44000+  Get users baud rate and parity in a string format
  35. '  COMPDATE   59200+  Produces a computational data from YY, MM, DD
  36. '  CONVDIRS   58950   Checks for U & A (shorthand) and converts appropriately
  37. '  COPYWRIT      97   Display RBBS-PC's copyright notice
  38. '  CTNEWFILES 58150   Check for number of files uploaded after a specific date
  39. '  CTLINES    58160   Find the number of entries in the upload management sys.
  40. '  DEFALTU     9600   Write out the user's defaults
  41. '  DELAYIT    50500   Wait number of seconds specified before returning
  42. '  DISPLAYTR  41010+  Compute and display time remaining
  43. '  DISUPDIR   58170   Display the shared directory of the FMS mng. sys. ' CPC15-1B
  44. '  DOOREXIT   10987   Set up a .BAT file to exit RBBS-PC and go to a "door"
  45. '  DOSEXIT    10934   Set up a .BAT file to exit to DOS (second level)
  46. '  FILELOCK   21995   Allow files to be shared among multiple RBBS-PC's
  47. '  FINDFUNC   58040   Find the function key, if any, that was depressed
  48. '  FINDLAST   58600   Finds last occurence of a string in a string
  49. '  FINDTIME   58050   Calculate the number of seconds since midnight
  50. '  FMS        58200   Search the upload management system for entries
  51. '  GETCOMND      97+  Get RBBS-PC's node id from command line
  52. '  GETDIRS    58900   Prompts for directories for file list/new/search cmds
  53. '  GETIME      9140   Calculates callers elapsed time (hours, minutes, seconds)
  54. '  GETYMD     59200   Pulls YY, MM, or DD from a 2 byte stored date
  55. '  GRAPHIC    43031   Determines whether graphic version of file exists
  56. '  HASHRBBS   58080   "Hash" to a user's record in the USERS file
  57. '  HELP        1330   Processes help command
  58. '  INSCOMMA   58130   Format commands in the command prompt
  59. '  INITFMS    58160+  Initialize the managment upload system
  60. '  KILLMSG     3955   Delete old or unnecessary messages
  61. '  LINE25       949   Build and/or update line 25 of RBBS-PC's local screen
  62. '  LOADNEW    58140   Find the latest uploads
  63. '  LOGERROR   13660   Log error message to CALLERS file
  64. '  MLINIT        50   Handle MultiLink initialization/de-initialization
  65. '  MODEMPUT   52070   Write a modem command string to the modem
  66. '  MUSIC      59100   Play musical themes for different RBBS functions
  67. '  OPENMSG    30500   Open the messages file as file number 1
  68. '  PROTOCOL   62600   Determine if external protocols are available
  69. '  PRTCRLF     1478   Write "snoop" lines that may have imbedded CR/LF's
  70. '  QTPUT       1477   Fast, but limited, "TPUT" equivalent
  71. '  RBBSEXIT   10992   Common RBBS-PC exit to transfer control to other programs
  72. '  READPROF   44000   Read user's profile on return from a "door"
  73. '  RECOVMSG   10410   Recover a deleted message
  74. '  REMOVE     58210   Remove characters from within strings
  75. '  ROTORSDIR  58700   Searches for a file using list of subdirs
  76. '  SAVEPROF   43070   Save the user's provile when exiting to "doors" or DOS
  77. '  SETBAUD     1654   Set baud rate in the 8250 chip of the RS232 interface
  78. '  SETCRLF     1496   Set up the necessary carriage return/line feed string
  79. '  SETOPTS    58100   Set correct prompt line for each subsystem
  80. '  SKIPLINE    1485   Write a # of blank lines to the communications port
  81. '  SRCHCMND    1240   Searches list of commands in RBBS for a request
  82. '  SRTSTRNG   58120   Sort characters in a string
  83. '  SYSMENU      112   Displays sysop menu/status
  84. '  TIMEREMAIN 41010   Compute time remaining in minutes
  85. '  TRANSFER   62620   RBBS-PC support for external protocols for file transfer
  86. '  TRIM          99   Strip leanding and trailing blanks from a string
  87. ' TWOBYTEDATE 59200   Reduces a data to 2 byte string for space compression
  88. '  UNTILRIGHT 12880   Ask a question until user says answer is right ' CPC15-1B
  89. '  UPDATEU    10600   Updates the user record on loging off/exiting RBBS-PC
  90. '  UPDTUPLOAD 20705   Updates upload directory file
  91. '  VIEWARC    64600   Display .ARC file contents to user
  92. '  WILDCARD   20285   Determines whether string matches a pattern
  93. '  WIPELINE   58800   Wipes away a line so next prints in its place
  94. '  WORDINFILE 10976   Find a whole word within a file/menu
  95. '
  96. '  $INCLUDE: 'RBBS-VAR.BAS'
  97. '
  98. '  $SUBTITLE: 'MLINIT - MultiLink initialization/deinitialization'
  99. '  $PAGE
  100. '
  101. '  SUBROUTINE NAME    -- MLINIT
  102. '
  103. '  INPUT PARAMETERS   --  MLPARM = 1             INITIALIZE AT STARTUP OR RE-
  104. '                                                CYLCE TIME
  105. '                         MLPARM = 2             DE-INITIALIZE ON EXITING TO
  106. '                                                A DOOR OR DOS REMOTELY
  107. '                         MLPARM = 3             DE-QUEUE COMMUNICATIONS PORTS
  108. '                         MLPARM = 4             CHECK FOR MULTILINK PRESENT
  109. '                         DOORS.TERMINAL.TYPE
  110. '                         BAUD.TEST
  111. '                         COM.PORT$
  112. '                         COMPUTER.TYPE
  113. '
  114. '  OUTPUT PARAMETERS  --  NONE
  115. '
  116. '  SUBROUTINE PURPOSE --  TO TEST FOR THE PRESENCE OF MULTI-LINK AND SET
  117. '                         MULTI LINK OPTIONS TO BE COMPATIBLE WITH RBBS-PC
  118. '
  119.       SUB MLINIT (MLPARM) STATIC
  120.     DEF SEG = 0
  121.     IF COMPUTER.TYPE = 1 _
  122.        GOTO 10
  123.     IF NOT MLCOM THEN _
  124.        IF NETWORK.TYPE <> 1 THEN _
  125.           GOTO 10
  126.     MULTI.LINK.PRESENT = PEEK(&H1FE) + 256*PEEK(&H1FF)
  127.     IF MULTI.LINK.PRESENT = 0 THEN _
  128.        GOTO 10
  129.     ON MLPARM GOSUB 30,20,60,10
  130. 10  DEF SEG
  131.     EXIT SUB
  132. 20  IF DOORS.TERMINAL.TYPE < 1 THEN _
  133.        RETURN
  134.     DEF SEG = MULTI.LINK.PRESENT
  135.     GOSUB 60
  136. '
  137. ' *****************************************************************************
  138. ' *                  MLUTIL BAUD n (where n = BAUD.TEST)                      *
  139. ' *****************************************************************************
  140. '
  141.     AX = &H600
  142.     BX = BAUD.TEST   ' Tell ML the baud rate
  143.     GOSUB 80
  144. '
  145. ' *****************************************************************************
  146. ' *                  MLUTIL TERM n (where n = DOORS.TERMINAL.TYPE)            *
  147. ' *****************************************************************************
  148. '
  149.     AX = &H700 + DOORS.TERMINAL.TYPE
  150.     GOSUB 80         ' Tell ML the terminal type
  151. '
  152. ' *****************************************************************************
  153. ' *                  MLINK /port                                              *
  154. ' *****************************************************************************
  155. '
  156. '                    ' Tell ML the communications port
  157.     POKE (&H64+PEEK(&H58)+256*PEEK(&H59)+&HC),ASC(RIGHT$(COM.PORT$,1))-48
  158. '
  159. ' *****************************************************************************
  160. ' *                  MLUTIL SCMON                                             *
  161. ' *****************************************************************************
  162. '
  163.     AX = &HB01
  164.     BX = 0           ' Tell ML to start monitoring the carrier
  165.     GOSUB 80
  166.     RETURN
  167. '
  168. ' *****************************************************************************
  169. ' *                  MLUTIL CCMON                                             *
  170. ' *****************************************************************************
  171. '
  172. 30  AX = &HB00       ' Turn off ML's carrier monitoring.
  173.     BX = 0
  174.     GOSUB 80
  175. '
  176. ' *****************************************************************************
  177. ' *                  MLUTIL TERM 1                                            *
  178. ' *****************************************************************************
  179. '
  180.     AX = &H701       ' Change terminal type to ML type 1.
  181.     BX = 0
  182.     GOSUB 80
  183. '
  184. ' *****************************************************************************
  185. ' *                  MLINK /port (where port = 9 if ML 3.03 or earlier        *
  186. ' *                                     port = 0 if ML 4.00 or greater        *
  187. ' *****************************************************************************
  188. '
  189.     DEF SEG = MULTI.LINK.PRESENT
  190.     MULTI.LINK.COM.PORT = (&H64 + PEEK(&H58) + 256*PEEK(&H59) + &HC)
  191.     MULTI.LINK.VERSION = PEEK(&H1) + 256*PEEK(&H2)
  192.     IF PEEK(MULTI.LINK.COM.PORT) = &H1 OR &H2 THEN _
  193.        IF MULTI.LINK.VERSION > 5000 THEN _
  194.           POKE (MULTI.LINK.COM.PORT),&H0 _
  195.        ELSE POKE (MULTI.LINK.COM.PORT),&H9
  196. '
  197. ' *****************************************************************************
  198. ' *                  MLUTIL ENQ                                               *
  199. ' *****************************************************************************
  200. '
  201.     AX = &H1        ' Tell ML to conditional enque on the comm. port
  202.     GOSUB 70
  203. '
  204. ' *****************************************************************************
  205. ' *                  MLUTIL BAUD 19200                                        *
  206. ' *****************************************************************************
  207. '
  208.     AX = &H600       ' Tell ML to reset the buad rate (19200 BAUD)
  209.     BX = 19200
  210.     GOSUB 80
  211.     RETURN
  212. '
  213. ' *****************************************************************************
  214. ' *                  MLUTIL DEQ                                               *
  215. ' *****************************************************************************
  216. '
  217. 60 AX = &H100        ' Tell ML to unconditionally deque the comm. port
  218. 70 BX = -4
  219.    IF COM.PORT$ = "COM2" THEN _
  220.       BX = -3
  221. '
  222. ' *****************************************************************************
  223. ' *  MULTI-LINK PROGRAMMING SUPPORT INTERFACE                                 *
  224. ' *****************************************************************************
  225. '
  226. 80 CALL RBBSML(AX,BX)
  227.    RETURN
  228.    END SUB
  229. '  $SUBTITLE: 'COPYWRIT - subroutine to display RBBS-PC copyright'
  230. '  $PAGE
  231. '
  232. '  SUBROUTINE NAME    -- COPYWRIT
  233. '
  234. '  INPUT PARAMETERS   --  NONE
  235. '
  236. '  OUTPUT PARAMETERS  --  NONE
  237. '
  238. '  SUBROUTINE PURPOSE --  TO DISPLAY RBBS-PC'S COPYRIGHT NOTICE ON THE LOCAL
  239. '                         SYSOP'S SCREEN
  240. '
  241.       SUB COPYWRIT STATIC
  242. 97 WIDTH 80
  243.    CLS
  244.    KEY OFF
  245.    LOCATE ,,0
  246.    PRINT TAB(60)"tm"
  247.    PRINT TAB(16) STRING$(15,205)" U S E R W A R E " STRING$(15,205)
  248.    PRINT
  249.    PRINT TAB(17)"Capital PC User Group User-Supported Software"
  250.    PRINT
  251.    PRINT TAB(5) CHR$(214) STRING$(66,196) CHR$(183)
  252.    FOR I = 1 TO 12
  253.      READ A$
  254.      PRINT TAB(5) CHR$(186);A$; SPACE$(66 - LEN(A$)); CHR$(186)
  255.    NEXT
  256.    PRINT TAB(5) CHR$(211) STRING$(66,196) CHR$(189)
  257.    PRINT TAB(21)"Copyright (c) 1983-87 Tom Mack, 10210 Oxfordshire Road, Great Falls, VA"
  258.    DATA "    If you are using RBBS-PC CPC15.1 and find it valuable, I"
  259.    DATA "    suggest you consider a contribution to"
  260.    DATA ""
  261.    DATA "                 Capital PC Software Exchange"
  262.    DATA "                     Post Office Box 6128"
  263.    DATA "                Silver Spring, Maryland  20906"
  264.    DATA ""
  265.    DATA "    You are free to copy and share RBBS-PC CPC15.1 with"
  266.    DATA "    others on these three conditions:"
  267.    DATA "      1.  This program is not distributed in modified form."
  268.    DATA "      2.  No fee or consideration is charged for RBBS-PC, itself."
  269.    DATA "      3.  This notice is not bypassed or removed."
  270.    CALL DELAYIT (8)
  271.    END SUB
  272. ' $SUBTITLE: 'GETCOMND - subroutine to get command from command line'
  273. ' $PAGE
  274. '
  275. '  SUBROUTINE NAME    -- GETCOMND
  276. '
  277. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  278. '                        CONFIG.FILENAME$     NAME OF RBBS-PC ".DEF" FILE TO
  279. '                                             USE AS A MODEL WHEN CREATING THE
  280. '                                             .DEF FILE NAME TO BE USED BY THIS
  281. '                                             COPY OF RBBS-PC.
  282. '
  283. '                        COMMAND LINE         COMMAND LINE USED TO INVOKE
  284. '                                             RBBS-PC IN THE FORM:
  285. '
  286. '             RBBS-PC.EXE x filename DEBUG /time /baud
  287. '
  288. '   WHERE THE OPTIONAL PARAMETERS ARE:
  289. '
  290. '  x       IS THE NODE ID IN THE RANGE 1-9,0,A-Z
  291. ' filename IS THE FULLY QUALIFIED FILE NAME TO USE AS THE ".DEF" FILE
  292. ' DEBUG    IS A DEBUGGING SWITCH
  293. ' /time    IS THE TIME OF DAY FOR RBBS-PC TO RETURN TO THE CALLER
  294. ' /baud    IS THE BAUD RATE OF THE CALLER IF RBBS-PC IS BEING SHELLED TO BY
  295. '             ANOTHER COMMUNICATIONS PROGRAM (THE COMMUNICATIONS PORT BEING
  296. '             USED IS ASSUMED TO BE THE ONE INPUTTED VIA THE RBBS-PC CONFIG
  297. '             PROGRAM
  298. ' 
  299. ' IF NO PARAMETERS ARE SUPPLIED, RBBS-PC ASSUMES THAT THE .DEF FILE NAME IS
  300. ' RBBS-PC.DEF AND THAT THE NODE IS NODE 1.
  301. ' 
  302. '  OUTPUT PARAMETERS  -- CONFIG.FILENAME$     NAME OF RBBS-PC ".DEF" FILE FOR
  303. '                                             THIS COPY OF RBBS-PC TO USE
  304. '                        NODE.RECORD.INDEX    RECORD NUMBER WITHIN THE
  305. '                                             MESSAGES FILE FOR THIS "NODE"
  306. '                                             (RANGE IS 2 TO 36)
  307. '
  308. '  SUBROUTINE PURPOSE --  TO GET NODE ID FROM COMMAND LINE
  309. '
  310.       SUB GETCOMND (PASSED.DEBUG,NETIME$,NETBAUD$) STATIC            ' CPC15-1B
  311.       STATIC DEBUG
  312. '
  313. ' *****************************************************************************
  314. ' *  GET NODE ID FROM COMMAND LINE                                            *
  315. ' *****************************************************************************
  316. '
  317.       PM$ = COMMAND$
  318.       CALL ALLCAPS(PM$)
  319.       IF INSTR(PM$,"/") = 0 THEN _                                   ' CPC15-1B
  320.          GOTO 98
  321. '
  322. ' *****************************************************************************
  323. ' * PARSE THE COMMAND LINE FOR TWO POSITIONAL SWITCHES FOR NET MAIL           *
  324. ' *****************************************************************************
  325. '
  326.       CMD.LINE$ = MID$(PM$,INSTR(PM$,"/") + 1,LEN(PM$) - INSTR(PM$,"/")) ' CPC15-1B
  327.       PM$ = LEFT$(PM$,INSTR(PM$,"/") - 1)                            ' CPC15-1B
  328.       IF INSTR(CMD.LINE$,"/") = 0 THEN _                             ' CPC15-1B
  329.          NETIME$ = CMD.LINE$ : _                                     ' CPC15-1B
  330.          NETBAUD$ = ""                                               ' CPC15-1B
  331.       IF INSTR(CMD.LINE$,"/") > 0 THEN _                             ' CPC15-1B
  332.          NETIME$ = LEFT$(CMD.LINE$,INSTR(CMD.LINE$,"/") - 1) : _     ' CPC15-1B
  333.          NETBAUD$ = MID$(CMD.LINE$,INSTR(CMD.LINE$,"/") + 1)         ' CPC15-1B
  334.       CALL TRIM(NETIME$)                                             ' CPC15-1B
  335.       CALL TRIM(NETBAUD$)                                            ' CPC15-1B
  336. 98    A = INSTR(PM$,"DEBUG")
  337.       IF A>0 THEN _
  338.          DEBUG = -1 : _
  339.          PM$ = LEFT$(PM$,A-1) + RIGHT$(PM$,LEN(PM$)-A-4)
  340.       PASSED.DEBUG = DEBUG
  341.       IF LEN(PM$) = 0 THEN _
  342.          PM$ = "-"
  343.       NODE.RECORD.INDEX = INSTR("-1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ",LEFT$(PM$,1))
  344.       IF NODE.RECORD.INDEX < 2 THEN _
  345.          NODE.RECORD.INDEX = 2
  346.       NODE.ID$ = STR$(NODE.RECORD.INDEX-1)
  347.       IF LEN(PM$) > 2 AND MID$(PM$,2,1) = " " THEN _
  348.          CONFIG.FILENAME$ = MID$(PM$,3)_
  349.       ELSE MID$(CONFIG.FILENAME$,5,1) = PM$
  350.       END SUB
  351. ' $SUBTITLE: 'TRIM - subroutine to eliminate leading/trailing blanks'
  352. ' $PAGE
  353. '
  354. '  SUBROUTINE NAME    -- TRIM
  355. '
  356. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  357. '                        TRIM.PARM$           STRING THAT IS TO HAVE LEADING
  358. '                                             AND TRAILING BLANKS ELIMINATED  
  359. '                                             FROM
  360. ' 
  361. '  OUTPUT PARAMETERS  -- TRIM.PARM$           STRING WITH NO LEADING OR TRAIL-
  362. '                                             ING BLANKS
  363. '
  364. '  SUBROUTINE PURPOSE --  TO STRIP LEADING AND TRAILING BLANKS
  365. '
  366.       SUB TRIM (TRIM.PARM$) STATIC                                   ' CPC15-1B
  367. 99    L = INSTR(TRIM.PARMS$," ")                                     ' CPC15-1B
  368.       IF L < 1 THEN _                                                ' CPC15-1B
  369.          EXIT SUB                                                    ' CPC15-1B
  370.       IF L = 1 THEN _                                                ' CPC15-1B
  371.          WHILE LEFT$(TRIM.PARM$,1) = " " : _                         ' CPC15-1B
  372.             TRIM.PARM$ = RIGHT$(TRIM.PARM$,LEN(TRIM.PARM$)-1) : _    ' CPC15-1B
  373.          WEND                                                        ' CPC15-1B
  374.       WHILE RIGHT$(TRIM.PARM$,1) = " "                               ' CPC15-1B
  375.         TRIM.PARM$ = LEFT$(TRIM.PARM$,LEN(TRIM.PARM$)-1)             ' CPC15-1B
  376.       WEND                                                           ' CPC15-1B
  377.       END SUB                                                        ' CPC15-1B
  378. '
  379. '  $SUBTITLE: 'SYSMENU - subroutine to display RBBS-PC SYSOP menu'
  380. '  $PAGE
  381. '
  382. '  SUBROUTINE NAME    --  SYSMENU
  383. '
  384. '  INPUT PARAMETERS   --  PARAMETER           MEANING
  385. '                           DELAY!    TIME IN SECONDS AFTER MIDNIGHT TO WAIT
  386. '                                     BEFORE DISPLAYING
  387. '
  388. '  OUTPUT PARAMETERS  --  NONE
  389. '
  390. '  SUBROUTINE PURPOSE --  TO DISPLAY RBBS-PC's SYSOP MENU ON THE LOCAL SCREEN
  391. '
  392.     SUB SYSMENU STATIC
  393.     DELAY! = 0
  394. 112 LOCAL.USER = TRUE
  395.     SNOOP = TRUE
  396.     PAGE.LENGTH.HOLD = PAGE.LENGTH
  397.     PAGE.LENGTH = 0
  398.     SUBROUTINE.PARAMETER = 1
  399.     WHILE SUBROUTINE.PARAMETER = 1
  400.       CALL CHECKTIM (DELAY!)
  401.     WEND
  402.     CLS
  403.     BYPASS.TIME.CHECK = TRUE
  404.     SECONDS.PER.SESSION! = 4
  405.     CALL BUFFILE ("MENU0")
  406.     BYPASS.TIME.CHECK = FALSE
  407.     LOCAL.USER = FALSE
  408.     PAGE.LENGTH = PAGE.LENGTH.HOLD
  409.     IF NOT OK THEN _
  410.        PRINT "MENU0 not on default drive"
  411.     LOCATE 2,18
  412.     PRINT LEFT$(VERSION.ID$,8);
  413.     LOCATE 2,58
  414.     X$ = DATE$
  415.     PRINT LEFT$(X$,6)+RIGHT$(X$,2);
  416.     LOCATE 2,72
  417.     PRINT LEFT$(TIME$,5);
  418.     IF DEBUG THEN _
  419.        LOCATE 16,1 : _
  420.        PRINT "DEBUG Active";
  421.     LOCATE 18,23
  422.     PRINT NODE.ID$;
  423.     LOCATE 18,74
  424.     PRINT MID$(STR$(FRE("A")),2)
  425.     IF COLOR.SUPPORT THEN _
  426.        LOCATE 20,23 : _
  427.        PRINT "YES";
  428.     IF RESTRICT.BAUD THEN _
  429.        LOCATE 20,51 : _
  430.        PRINT "NO ";
  431.     IF EXTENDED.LOGGING THEN _
  432.        LOCATE 20,75 : _
  433.        PRINT "YES";
  434.     IF FMS.DIRECTORY$ <> "" THEN _
  435.        LOCATE 22,75 : _
  436.        PRINT "YES";
  437.     END SUB
  438. ' $SUBTITLE: 'BADCHAR - subroutine to check user names for bad characters'
  439. ' $PAGE
  440. '
  441. '  SUBROUTINE NAME    -- BADCHAR
  442. '
  443. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  444. '                           PASSED.NAME$           USER NAME
  445. '
  446. '  OUTPUT PARAMETERS  --    PASSED.NAME$           USER NAME WILL CONTAIN ""
  447. '                                                  IF BAD CHARACTERS FOUND
  448. '
  449. '  SUBROUTINE PURPOSE -- TO CHECK USER NAMES FOR INVALID CHARACTERS
  450. '
  451.     SUB BADCHAR (PASSED.NAME$) STATIC
  452. '
  453.     J = 1
  454.     XX = LEN(PASSED.NAME$)
  455. 457 IF J > XX THEN _
  456.        EXIT SUB
  457.     X = ASC(MID$(PASSED.NAME$,J,1))
  458.     IF (X < 65 OR X > 90) AND _
  459.        (X <> 32 AND X <> 39 AND X <> 45 AND X <> 46) THEN _
  460.        PASSED.NAME$ = "" : _
  461.        EXIT SUB
  462.     J = J + 1
  463.     GOTO 457
  464.     END SUB
  465. ' $SUBTITLE: 'LINE25 - subroutine to build/display RBBS-PCs line 25'
  466. ' $PAGE
  467. '
  468. '  SUBROUTINE NAME    -- LINE25
  469. '
  470. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  471. '                        SUBROUTINE.PARAMETER = 1  BUILD DISPLAY FOR LINE 25
  472. '                        SUBROUTINE.PARAMETER = 2  UPDATE LINE 25
  473. '                        LOCK.STATUS$              STATUS OF LOCKS IN A MULTI-
  474. '                                                  USER ENVIRONMENT OR TIME OF
  475. '                                                  DAY USER LOGGED ON OR THE
  476. '                                                  RE-CYCLED
  477. '
  478. '  OUTPUT PARAMETERS  -- CURSOR.LINE               CURRENT LINE ON SCREEN
  479. '                        CURSOR.ROW                CURRENT ROW ON CURSOR.LINE
  480. '
  481. '  SUBROUTINE PURPOSE -- TO BUILD OR UPDATE RBBS-PC'S LINE 25 DISPLAYED
  482. '                        ON THE PC SCREEN THAT IS RUNNING RBBS-PC.
  483. '
  484.       SUB LINE25 STATIC
  485.       ON SUBROUTINE.PARAMETER GOTO 949,950
  486. '
  487. ' *****************************************************************************
  488. ' *  BUILD LINE 25 DISPLAY                                                    *
  489. ' *****************************************************************************
  490. '
  491. 949 LINE.25$ = MID$("    AVL ",1-4*SYSOP.AVAILABLE,4) + _
  492.                MID$("    ANY ",1-4*SYSOP.ANNOY,4) + _
  493.                MID$("    LPT ",1-4*PRINTER,4) + _
  494.                MID$("SYS",1,-3*SYSOP.NEXT)
  495. '
  496. ' *****************************************************************************
  497. ' *  LINE 25 UPDATE ROUTINE                                                   *
  498. ' *****************************************************************************
  499. '
  500. 950 IF NOT SNOOP THEN _
  501.        EXIT SUB
  502.     CURSOR.LINE = CSRLIN
  503.     CURSOR.ROW = POS(0)
  504.     HH = LEN(ACTIVE.USER.NAME$) + LEN(CI$) + LEN(LINE.25$) + 18
  505.     IF AUTODOWNLOAD.AVAILABLE THEN _
  506.        HH = HH + 4
  507.     LOCATE 25,1
  508.     IF NETWORK.TYPE = 0 THEN _
  509.        IF AUTODOWNLOAD.AVAILABLE THEN _
  510.           LOCK.STATUS$ = SPACE$(3) + _
  511.                          "AD  " + _
  512.                          TIME.LOGGED.ON$ _
  513.        ELSE LOCK.STATUS$ = SPACE$(3)+TIME.LOGGED.ON$
  514.     IF HH>79 THEN _
  515.        HH=78
  516.     PRINT LINE.25$+SPACE$(79-HH)+STR$(USER.SECURITY.LEVEL)+" "+ACTIVE.USER.NAME$+" "+CI$+" "+LOCK.STATUS$;
  517.     LOCATE CURSOR.LINE,CURSOR.ROW
  518.     END SUB
  519. ' $SUBTITLE: 'SRCHCMND    - subroutine to search command list'
  520. ' $PAGE
  521. '
  522. '  SUBROUTINE NAME    -- SRCHCMND
  523. '
  524. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  525. '                        STRT.POS      POSITION TO BEGIN SEARCH AT
  526. '                        ALL.OPTS$     STRING TO SEARCH (COMMAND LIST)
  527. '                        Z$            WHAT TO LOOK FOR
  528. '
  529. '  OUTPUT PARAMETERS  -- WHERE.FOUND   POSITION OF Z$ IN ALL.OPTS$
  530. '                                      0 IF NOT FOUND
  531. '
  532. '  SUBROUTINE PURPOSE -- SEARCHES VALID COMMAND LIST FOR THE REQUESTED
  533. '                        COMMAND.  IF THE SYSOP HAS CONFIGURED RBBS-PC TO
  534. '                        RESTRICT COMMANDS TO ONLY THOSE VALID WITHIN THE
  535. '                        RBBS-PC SUBSYSTEM, THEN ONLY THOSE COMMANDS AND
  536. '                        "GLOBAL" COMMANDS ARE VALID.  OTHERWISE ALL COMMANDS
  537. '                        ARE VALID FROM ANY OF THE RBBS-PC SUBSYSTEMS.
  538. '
  539.      SUB SRCHCMND (STRT.POS,WHERE.FOUND) STATIC
  540. 1240 WHERE.FOUND = INSTR(STRT.POS,ALL.OPTS$,Z$)
  541.      IF WHERE.FOUND = 0 THEN _  'Not found: decide whether to hunt further
  542.         IF STRT.POS < 2 OR RESTRICT.VALID.CMDS THEN _
  543.            EXIT SUB _  ' fully searched or restricted
  544.         ELSE _
  545.            WHERE.FOUND = INSTR(1,ALL.OPTS$,Z$) : _ 'hunt further
  546.            EXIT SUB
  547.      IF NOT RESTRICT.VALID.CMDS THEN _
  548.         EXIT SUB             ' everything found valid
  549. '
  550. ' *****************************************************************************
  551. ' * RESTRICT COMMANDS TO SUBSYSTEMS (EXCEPT GLOBAL AND SYSOP)                 *
  552. ' *****************************************************************************
  553. '
  554.      IF WHERE.FOUND > LEN(ALL.OPTS$)-11 THEN _
  555.         EXIT SUB                          ' ACCEPT GLOBAL & SYSOP
  556.      IF MID$(ALL.OPTS$,WHERE.FOUND,1) = "G" THEN _
  557.         EXIT SUB                          ' ACCEPT GOODBYE/GRAPHICS
  558.      IF (STRT.POS < BEG.FILE AND WHERE.FOUND >= BEG.FILE ) OR _
  559.         (STRT.POS < BEG.UTIL AND WHERE.FOUND >= BEG.UTIL ) THEN _
  560.           WHERE.FOUND = 0                 ' REJECT: NOT IN SECTION
  561.      END SUB
  562. ' $SUBTITLE: 'HELP    - Processes requests for help'
  563. ' $PAGE
  564. '
  565. '  SUBROUTINE NAME    -- HELP
  566. '
  567. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  568. '                       SECTION             ORDER OF 1ST COMMAND IN CURRENT
  569. '                                              SECTION
  570. '                       GRAPHICS.DEFAULT    WHAT GRAPHICS TYPE USER WANTS
  571. '                       HELP.DEFAULT$       HELP GET IF PRESS ENTER
  572. '                       HELP.PATH$
  573. '                       HELP.EXTENSION$
  574. '                       BEG.FILE
  575. '                       BEG.MAIN
  576. '                       BEG.UTIL
  577. '
  578. '  OUTPUT PARAMETERS  -- DISPLAYS HELP
  579. '
  580. '  SUBROUTINE PURPOSE -- THE MAIN HELP PROCESSOR FOR RBBS.  PUTS UP THE
  581. '                        OPTIONAL MENU.  ACCEPTS HELP WITH INDIVIDUAL
  582.      SUB HELP (SECTION,GRAPHIC.DEFAULT$,HELP.DEFAULT$) STATIC
  583. 1330 HELP.MENU$ = HELP.PATH$+"HELP"+HELP.EXTENSION$
  584.      GOT.MENU = TRUE
  585.      IF Q>1 THEN _
  586.         ANS.INDEX = 2 : _
  587.         LAST.INDEX = Q: _
  588.         GOTO 1332
  589. 1331 IF GOT.MENU THEN _
  590.         FILE.NAME$ = HELP.MENU$ : _
  591.         GOSUB 1350 : _
  592.         GOT.MENU = OK
  593.      ANS.INDEX = 1
  594.      A$ = "HELP with (LETTER/SECTION/TOPIC, [ENTER]="+HELP.DEFAULT$+", [QH]=quit HELP)"
  595.      SUBROUTINE.PARAMETER = 1
  596.      CALL TGET
  597.      IF SUBROUTINE.PARAMETER = -1 THEN _
  598.         EXIT SUB
  599.      IF Q = 0 THEN _
  600.         Q = 1:_
  601.         B$(1) = HELP.DEFAULT$
  602.      LAST.INDEX = Q
  603. 1332 Z$ = B$(ANS.INDEX)
  604.      CALL ALLCAPS (Z$)
  605.      IF Z$="QH" THEN _
  606.         EXIT SUB
  607.      IF Z$ = "?" THEN _
  608.         Z$ = "H"
  609.      CALL BADFILE (Z$,BAD.FILE.NAME.INDEX)
  610.      ON BAD.FILE.NAME.INDEX GOTO 1333,1340,1340
  611. 1333 IF LEN(Z$) = 1 THEN _
  612.         CALL SRCHCMND (SECTION,FF) : _
  613.         IF FF<1 THEN _
  614.            OK = FALSE :_
  615.            GOTO 1334 _
  616.         ELSE X = -(FF>=BEG.MAIN)-(FF>=BEG.FILE)-(FF>=BEG.UTIL):_
  617.              Z$ = MID$("MFU",X,1) + Z$
  618.      FILE.NAME$ = HELP.PATH$ + Z$ + HELP.EXTENSION$
  619.      GOSUB 1350
  620. 1334 IF NOT OK THEN _
  621.         A$ = "No help for "+Z$ :_
  622.         CALL QTPUT (A$,1) : _
  623.         CALL UPDTCALR (A$,2)
  624.      ANS.INDEX = ANS.INDEX + 1
  625.      IF ANS.INDEX <= LAST.INDEX THEN _
  626.         GOTO 1332
  627.      GOTO 1331
  628. 1340 OK = FALSE
  629.      GOTO 1334
  630. 1350 CALL GRAPHIC (GRAPHIC.DEFAULT$)
  631.      CALL BUFFILE (FILE.NAME$)
  632.      RETURN
  633.      END SUB
  634. ' $SUBTITLE: 'QTPUT    - subroutine to quickly write to terminal'
  635. ' $PAGE
  636. '
  637. '  SUBROUTINE NAME    -- QTPUT
  638. '
  639. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  640. '                        STRNG$        STRING TO WRITE OUT
  641. '                        NUM.RETURNS   NUMBER OF CARRIAGE RETURNS
  642. '
  643. '  OUTPUT PARAMETERS  -- NONE
  644. '
  645. '  SUBROUTINE PURPOSE -- SUBROUTINE TO QUICKLY WRITE TO THE TERMINAL.  THIS IS
  646. '                        IS DIFFERENT FROM "TPUT" IN THE THINGS IT DOESN'T DO:
  647. '                                A.) NO FUNCTION KEY CHECK,
  648. '                                B.) NO CONVERSION TO UPPER CASE,
  649. '                                C.) NO STRING RE-INITILIZATION OF "STRNG$",
  650. '                                D.) NO CHECK FOR CARRIER PRESENT, AND
  651. '                                E.) NO CHECK FOR IMBEDDED CARRIAGE RETURN IN
  652. '                                       "STRNG$".
  653. '                                F.) NO SUPPORT FOR XON/XOFF
  654. '
  655.       SUB QTPUT (STRNG$,NUM.RETURNS) STATIC
  656.       IF UPPER.CASE THEN _
  657.          GOTO 1476
  658.       IF COLOR.SUPPORT THEN _
  659.          IF SNOOP THEN _
  660.             GOTO 1476
  661.       IF NOT LOCAL.USER THEN _
  662.          PRINT #3,STRNG$;
  663.       IF SNOOP THEN _
  664.          PRINT STRNG$;
  665.       CALL SKIPLINE (NUM.RETURNS)
  666.       GOTO 1477
  667. 1476  A$ = STRNG$
  668.       SUBROUTINE.PARAMETER = 4
  669.       CALL TPUT
  670.       CALL SKIPLINE (NUM.RETURNS)
  671. 1477  END SUB
  672. ' $SUBTITLE: 'PRTCRLF  - subroutine to write snoop lines'
  673. ' $PAGE
  674. '
  675. '  SUBROUTINE NAME    -- PRTCRLF
  676. '
  677. '  INPUT PARAMETERS   -- PARAMETER          MEANING
  678. '                         STRNG$             STRING TO WRITE TO SCREEN
  679. '
  680. '  OUTPUT PARAMETERS  -- NONE
  681. '
  682. '  SUBROUTINE PURPOSE -- TO WRITE OUT LINES TO THE LOCAL SYSOP'S SCREEN THAT
  683. '                        MAY HAVE INTERNAL CARRIAGE RETURN AND LINE FEEDS
  684. '                        IMBEDDED IN IT.
  685. '
  686.      SUB PRTCRLF (STRNG$) STATIC
  687. 1478 CURSOR.ROW = 1
  688.      L = LEN(STRNG$)
  689.      NUM.RETURNS = 0
  690.      WHILE CURSOR.ROW <= L
  691.        CURSOR.LINE = CURSOR.ROW + _
  692.                      INSTR(MID$(STRNG$,CURSOR.ROW) + _
  693.                      CARRIAGE.RETURN$,CARRIAGE.RETURN$) - 2
  694.        S1 = -(CURSOR.LINE < L)
  695.        PRINT MID$(STRNG$,CURSOR.ROW,CURSOR.LINE-CURSOR.ROW + 1); _
  696.              MID$(LINE.FEED$,1,S1);
  697.        CURSOR.ROW = CURSOR.LINE + LEN(RETURN.LINE.FEED$) + 1
  698.        NUM.RETURNS = NUM.RETURNS + S1
  699.      WEND
  700.      END SUB
  701. ' $SUBTITLE: 'SKIPLINE - subroutine to write a blank line to user'
  702. ' $PAGE
  703. '
  704. '  SUBROUTINE NAME    -- SKIPLINE
  705. '
  706. '  INPUT PARAMETERS   --   PARAMETER             MEANING
  707. '                        LOCAL.USER
  708. '                        MODEM.STATUS.REGISTER
  709. '                        NUM.RETURNS
  710. '                        RETURN.LINE.FEED$
  711. '                        SNOOP
  712. '
  713. '  OUTPUT PARAMETERS  -- NONE
  714. '
  715. '  SUBROUTINE PURPOSE -- SKIP A LINE ON THE USER'S TERMINAL
  716. '
  717.       SUB SKIPLINE (NUM.RETURNS) STATIC
  718. 1485  IF NOT LOCAL.USER AND INP(MODEM.STATUS.REGISTER) > 127 THEN _
  719.          FOR I=1 TO NUM.RETURNS:PRINT #3,RETURN.LINE.FEED$;:NEXT
  720.       IF SNOOP THEN _
  721.          FOR I=1 TO NUM.RETURNS:PRINT:NEXT
  722.       LINES.PRINTED = LINES.PRINTED + NUM.RETURNS
  723.       END SUB
  724. ' $SUBTITLE: 'SETCRLF -- subroutine to set up nulls/lf's for output'
  725. ' $PAGE
  726. '
  727. '  SUBROUTINE NAME    -- SETCRLF
  728. '
  729. '  INPUT PARAMETERS   --   PARAMETER          MEANING
  730. '                        CARRIAGE.RETURN$    CARRIAGE RETURN CHARACTER
  731. '                        CI$                 CITY/STATE OF CALLER
  732. '                        LINE.FEED$          LINE FEED CHARACTER
  733. '                        LINE.FEEDS          LINE FEED SWITCH
  734. '                        NUL$                NULL CHARACTER
  735. '
  736. '  OUTPUT PARAMETERS  -- RETURN.LINE.FEED$   END-OF-LINE STRING
  737. '
  738. '  SUBROUTINE PURPOSE -- SET UP THE NECESSARCY NULLS/LINE FEEDS TO END
  739. '                        EACH OUTPUT TO THE COMMUNICATIONS PORT WITH
  740. '
  741.       SUB SETCRLF STATIC
  742. 1496  RETURN.LINE.FEED$ = MID$(CARRIAGE.RETURN$,1,-(NOT LOCAL.USER)) + _
  743.                           NUL$ + _
  744.                           MID$(LINE.FEED$,1,-(LINE.FEEDS <> 0))
  745.       END SUB
  746. ' $SUBTITLE: 'SETBAUD - subroutine to set the baud rate in the RS232'
  747. ' $PAGE
  748. '
  749. '  SUBROUTINE NAME    -- SETBAUD
  750. '
  751. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  752. '                         BAUD.RATE.DIVISOR   NUMBER TO DIVIDE THE 8250 CHIP'S
  753. '                                             PROGRAMABLE CLOCK TO ADJUST THE
  754. '                                             BAUD RATE TO THE USER'S BAUD
  755. '                                             RATE (INDEPENDENT OF THE BAUD
  756. '                                             RATE USED TO OPEN THE COMM. PORT)
  757. '
  758. '        DESIRED BAUD        DIVISIOR (DECIMAL) TO OBTAIN DESIRED BAUD RATE
  759. '            RATE              PCjr         PC AND XT
  760. '              50             2237             2304
  761. '              75             1491             1536
  762. '             110             1017             1047
  763. '             134.5            832              857
  764. '             150              746              768
  765. '             300              373              384
  766. '             600              186              192
  767. '            1200               93               96
  768. '            1800               62               64
  769. '            2000               56               58
  770. '            2400               47               48
  771. '            3600               31               32
  772. '            4800               23               24
  773. '            7200          not available         16
  774. '            9600          not available         12
  775. '
  776. '  OUTPUT PARAMETERS  -- BAUD RATE SET IN THE RS232 INTERFACE
  777. '
  778. '  SUBROUTINE PURPOSE -- TO SET THE BAUD RATE IN THE RS232 INTERFACE
  779. '                        INDEPENDENT OF THE BAUD RATE THE COMMUNICATIONS PORT
  780. '                        WAS OPENED AT
  781. '
  782.       SUB SETBAUD STATIC
  783. '
  784. ' *****************************************************************************
  785. ' *  BAUD RATE CHANGE ROUTINE                                                 *
  786. ' *****************************************************************************
  787. '
  788. 1654 LINE.CONTROL.STATUS = INP(LINE.CONTROL.REGISTER)
  789.      MSB.SAVE = INP(MSB)
  790.      OUT MSB,0
  791.      OUT LINE.CONTROL.REGISTER,LINE.CONTROL.STATUS OR 128
  792.      MOST.SIGNIFICANT.BYTE = FIX (BAUD.RATE.DIVISOR / 256)
  793.      LEAST.SIGNIFICANT.BYTE = BAUD.RATE.DIVISOR - (MOST.SIGNIFICANT.BYTE * 256)
  794.      OUT LSB,LEAST.SIGNIFICANT.BYTE
  795.      OUT MSB,MOST.SIGNIFICANT.BYTE
  796.      OUT LINE.CONTROL.REGISTER,LINE.CONTROL.STATUS
  797.      OUT MSB,MSB.SAVE
  798.      END SUB
  799. ' $SUBTITLE: 'KILLMSG - subroutine to delete messages'
  800. ' $PAGE
  801. '
  802. '  SUBROUTINE NAME    -- KILLMSG
  803. '
  804. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  805. '                         MESSAGE.TO.KILL              MESSAGE NUMBER TO KILL
  806. '                         ACTIVE.MESSAGES              NUMBER ACTIVE MESSAGES
  807. '
  808. '  OUTPUT PARAMETERS  --  NONE
  809. '
  810. '  SUBROUTINE PURPOSE --  TO KILL/DELETE OLD OR UNNECESSARY MESSAGES
  811. '
  812.      SUB KILLMSG (MESSAGE.TO.KILL,ACTIVE.MESSAGES) STATIC
  813. '
  814.      FIELD #1,128 AS MESSAGE.RECORD$
  815.      QX = 1
  816. 3955 IF QX > ACTIVE.MESSAGES THEN _
  817.         A$ = "No such msg #" + STR$(MESSAGE.TO.KILL) : _
  818.         GOTO 4031
  819.      IF M(QX,2) = MESSAGE.TO.KILL AND MESSAGE.TO.KILL >= 1 THEN _
  820.         GOTO 3970
  821.      QX = QX + 1
  822.      GOTO 3955
  823. 3970 SUBROUTINE.PARAMETER = 3
  824.      CALL FILELOCK
  825.      GET 1,M(QX,1)
  826.      IF SYSOP THEN _
  827.         GOTO 4030
  828. 3980 Z$ = MID$(MESSAGE.RECORD$,101,15)
  829.      Z$ = LEFT$(Z$ + SPACE$(2),INSTR(Z$ +SPACE$(2),SPACE$(2))-1)
  830.      IF LEN(Z$) = 0 THEN _
  831.         GOTO 4030
  832. 3990 IF Z$ = "^READ^" OR Z$ = "^KILL^" THEN _
  833.         IF INSTR(MESSAGE.RECORD$,ACTIVE.USER.NAME$) THEN _
  834.            GOTO 4030 _
  835.         ELSE MESSAGE.PASSWORD = TRUE : _
  836.              ATTEMPTS.ALLOWED = 0 : _
  837.              CALL QTPUT("Only sender & receiver can kill",1): _
  838.              GOTO 4031
  839. 4000 IF LEFT$(Z$,1) = "!" THEN _
  840.         Z$ = MID$(Z$,2)
  841. 4010 PASSWORD.SAVE$ = Z$ + SPACE$(15-LEN(Z$))
  842.      ATTEMPTS.ALLOWED = 1
  843.      MESSAGE.PASSWORD = TRUE
  844.      CALL PASSWORD
  845.      IF PASSWORD.FAILED THEN _
  846.         GOTO 4031
  847. 4030 LSET MESSAGE.RECORD$ = LEFT$(MESSAGE.RECORD$,115) + _
  848.                             DELETED.MESSAGE$ + _
  849.                             MID$(MESSAGE.RECORD$,117)
  850.      PUT 1,LOC(1)
  851.      A$ = "Killed Msg # " + STR$(MESSAGE.TO.KILL)
  852.      SUBROUTINE.PARAMETER = 4
  853.      CALL FILELOCK
  854.      SUBROUTINE.PARAMETER = 5
  855.      CALL TPUT
  856.      EXIT SUB
  857. 4031 SUBROUTINE.PARAMETER = 4
  858.      CALL TPUT
  859.     END SUB
  860. ' $SUBTITLE: 'GETIME - subroutine to calculate elapsed time'
  861. ' $PAGE
  862. '
  863. '  SUBROUTINE NAME    -- GETIME
  864. '
  865. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  866. '                         TIME.LOGGED.ON$
  867. '
  868. '  OUTPUT PARAMETERS  --  HH                     NUMBER OF HOURS ON
  869. '                         MM                     NUMBER OF MINUTES ON
  870. '                         SS                     NUMBER OF SECONDS ON
  871. '
  872. '  SUBROUTINE PURPOSE --  CALCULATE THE ELASPED TIME A USER HAS BEEN ON
  873. '
  874.      SUB GETIME STATIC
  875. 9140 H = VAL(MID$(TIME.LOGGED.ON$,1,2))
  876.      M = VAL(MID$(TIME.LOGGED.ON$,4,2))
  877.      S = VAL(MID$(TIME.LOGGED.ON$,7,2))
  878.      X$ = TIME$
  879.      HH = VAL(MID$(X$,1,2))
  880.      MM = VAL(MID$(X$,4,2))
  881.      JJ = VAL(MID$(X$,7,2))
  882.      IF S <= JJ THEN _
  883.         SSS = JJ-S _
  884.      ELSE SSS = 60-(S-JJ) : _
  885.           M = M + 1
  886. 9150 IF M <= MM THEN _
  887.         MMM = MM-M _
  888.      ELSE MMM = 60-(M-MM) : _
  889.           H = H + 1
  890. 9160 IF H <= HH THEN _
  891.         HHH = HH-H : _
  892.         GOTO 9161 _
  893.      ELSE HHH = 24-(H-HH)
  894. 9161 END SUB
  895. ' $SUBTITLE: 'DEFAULTU - subroutine to update user defauts'
  896. ' $PAGE
  897. '
  898. '  SUBROUTINE NAME    -- DEFAULTU
  899. '
  900. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  901. '                         AUTODOWNLOAD.DESIRED  
  902. '                         CHECK.BULLETIN.LOGON
  903. '                         EXPERT.USER
  904. '                         GR
  905. '                         LAST.MESSAGE.READ
  906. '                         LINE.FEEDS
  907. '                         NULLS
  908. '                         PAGE.LENGTH
  909. '                         PROMPT.BELL
  910. '                         REG.DATE$
  911. '                         REQ.QUES.ANSWERED
  912. '                         RIGHT.MARGIN
  913. '                         SKIP.FILES.LOGON
  914. '                         TIMES.LOGGED.ON
  915. '                         UPPER.CASE
  916. '                         USER.OPTIONS$
  917. '                         USER.TRANSFER.DEFAULT$
  918. '
  919. '  OUTPUT PARAMETERS  --  USER.OPTONS$
  920. '
  921. '  SUBROUTINE PURPOSE --  TO UPDATE THE USER'S RECORD WITH THEIR OPTIONS
  922. '
  923.      SUB DEFAULTU STATIC
  924. '
  925. ' *****************************************************************************
  926. ' * UPDATE USER DEFAULTS                                                      *
  927. ' *****************************************************************************
  928. '
  929. 9600 LSET USER.OPTIONS$ = _
  930.         MKI$(TIMES.LOGGED.ON) + _
  931.         MKI$(LAST.MESSAGE.READ) + _
  932.         USER.TRANSFER.DEFAULT$ + _
  933.         MID$(STR$(GR),2,1) + _
  934.         MKI$(RIGHT.MARGIN) + _
  935.         MKI$(-PROMPT.BELL-2*EXPERT.USER-4*NULLS-8*UPPER.CASE-16*LINE.FEEDS_
  936.              -32*CHECK.BULLETIN.LOGON - 64*SKIP.FILES.LOGON_
  937.              -128*AUTODOWNLOAD.DESIRED - 256*REQ.QUES.ANSWERED) + _  ' CPC15-1B
  938.         REG.DATE$ + _
  939.         CHR$(PAGE.LENGTH) + _
  940.         STRING$(1,0)
  941.      END SUB
  942. ' $SUBTITLE: 'RECOVMSG - subroutine to recover deleted messages'
  943. ' $PAGE
  944. '
  945. '  SUBROUTINE NAME    -- RECOVMSG
  946. '
  947. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  948. '                         MESSAGE.TO.RECOVER          MESSAGE NUMBER TO RECOVER
  949. '                         FIRST.MESSAGE.RECORD        RECORD # FOR FIRST MSG
  950. '
  951. '  OUTPUT PARAMETERS  --  ACTION.FLAG                 SET TO 0 IF ERROR
  952. '                                                     SET TO -1 IF NO ERROR
  953. '
  954. '  SUBROUTINE PURPOSE --  TO RECOVER DELETED MESSAGES.  NOTE THAT THIS IS ONLY
  955. '                         POSSIBLE IF YOU HAVE NOT COMPRESSED YOUR MESSAGE FILE
  956. '                         USING CONFIG.
  957.      SUB RECOVMSG (MESSAGE.TO.RECOVER,FIRST.MESSAGE.RECORD,ACTION.FLAG) STATIC
  958.       FIELD #1,128 AS MESSAGE.RECORD$
  959. 10410 MESSAGE.RECORD = FIRST.MESSAGE.RECORD
  960.       SUBROUTINE.PARAMETER = 5
  961.       CALL TPUT
  962. 10420 GET 1,MESSAGE.RECORD
  963.       NUMBER.RECORDS.IN.MESSAGE = VAL(MID$(MESSAGE.RECORD$,117,4))
  964.       IF NUMBER.RECORDS.IN.MESSAGE < 1 THEN _
  965.          A$ = "USE CONFIG TO REPAIR YOUR MESSAGE FILE" : _
  966.          SUBROUTINE.PARAMETER = 5 : _
  967.          GOTO 10485
  968.       IF MESSAGE.RECORD >= NEXT.MESSAGE.RECORD THEN _
  969.          A$ = "No Msg #" + STR$(MESSAGE.TO.RECOVER) : _
  970.          GOTO 10485
  971. 10440 IF VAL(MID$(MESSAGE.RECORD$,2,4)) <> MESSAGE.TO.RECOVER THEN _
  972.          MESSAGE.RECORD = MESSAGE.RECORD + NUMBER.RECORDS.IN.MESSAGE : _
  973.          GOTO 10420
  974. 10450 IF INSTR(MESSAGE.RECORD$,DELETED.MESSAGE$) <> 0 THEN _
  975.          SUBROUTINE.PARAMETER = 3 : _
  976.          CALL TPUT : _
  977.          LSET MESSAGE.RECORD$ = LEFT$(MESSAGE.RECORD$,115) + _
  978.                                 ACTIVE.MESSAGE$ + _
  979.                                 MID$(MESSAGE.RECORD$,117) : _
  980.          PUT 1,LOC(1) : _
  981.          SUBROUTINE.PARAMETER = 4 : _
  982.          CALL TPUT : _
  983.          A$ = "Restored Msg #" + STR$(MESSAGE.TO.RECOVER) : _
  984.          ACTION.FLAG = TRUE : _
  985.          GOTO 10485
  986. 10480 A$ = "Msg #" + STR$(MESSAGE.TO.RECOVER) + " not Dead"
  987. 10485 SUBROUTINE.PARAMETER = 5
  988.       CALL TPUT
  989.       END SUB
  990. ' $SUBTITLE: 'UPDATEU -- Update the users record at logoff'
  991. ' $PAGE
  992. '  SUBROUTINE NAME    -- UPDATEU
  993. '
  994. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  995. '                        ADJUSTED.SECURITY
  996. '                        CURRENT.DATE$
  997. '                        DOWNLOADS
  998. '                        ELAPSED.TIME
  999. '                        LIST.DIRECTORY
  1000. '                        MAIN.USER.FILE.INDEX
  1001. '                        SECONDS.PER.SESSION!
  1002. '                        UPLOADS
  1003. '                        USER.SECURITY.LEVEL
  1004. '
  1005. '  OUTPUT PARAMETERS  -- ELAPSED.TIME$
  1006. '                        LIST.NEW.DATE$
  1007. '                        SECURITY.LEVEL$
  1008. '                        USER.DOWNLOADS$
  1009. '                        USER.UPLOADS$
  1010. '
  1011. '  SUBROUTINE PURPOSE -- UPDATE THE USER RECORD FOR THE USER WHEN THE USER
  1012. '                        EXITS RBBS-PC.
  1013. '
  1014.       SUB UPDATEU STATIC
  1015. 10600 USER.FILE.INDEX = MAIN.USER.FILE.INDEX
  1016.       SUBROUTINE.PARAMETER = 6
  1017.       CALL FILELOCK
  1018.       CALL OPENUSER
  1019.       FIELD 5,31 AS USER.NAME$, _
  1020.               15 AS PASSWORD$, _
  1021.                2 AS SECURITY.LEVEL$, _
  1022.               14 AS USER.OPTIONS$,  _
  1023.               24 AS CITY.STATE$, _
  1024.               19 AS MACHINE.TYPE$, _
  1025.               14 AS LAST.DATE.TIME.ON$, _
  1026.                3 AS LIST.NEW.DATE$, _
  1027.                2 AS USER.DOWNLOADS$, _
  1028.                2 AS USER.UPLOADS$, _
  1029.                2 AS ELAPSED.TIME$
  1030. 10604 GET 5,USER.FILE.INDEX
  1031.       CALL DEFAULTU
  1032.       IF LIST.DIRECTORY THEN _
  1033.          LSET LIST.NEW.DATE$ = CHR$(VAL(MID$(CURRENT.DATE$,7,2)))+_
  1034.                                CHR$(VAL(MID$(CURRENT.DATE$,1,2)))+_
  1035.                                CHR$(VAL(MID$(CURRENT.DATE$,4,2)))
  1036. 10605 LSET USER.DOWNLOADS$ = MKI$(DOWNLOADS)
  1037.       LSET USER.UPLOADS$ = MKI$(UPLOADS)
  1038.       CALL TIMEREMAIN (TIME.REMAINING!)
  1039.       LSET ELAPSED.TIME$ = MKI$(ELAPSED.TIME + _
  1040.                          (SECONDS.PER.SESSION! / 60) - _
  1041.                           TIME.REMAINING!)
  1042.       IF ADJUSTED.SECURITY THEN _
  1043.          LSET SECURITY.LEVEL$ = MKI$(USER.SECURITY.LEVEL)
  1044.       PUT 5,USER.FILE.INDEX
  1045.       END SUB
  1046. ' $SUBTITLE: 'DOSEXIT -- Setup to exit to DOS for SYSOP'
  1047. ' $PAGE
  1048. '  SUBROUTINE NAME    -- DOSEXIT
  1049. '
  1050. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1051. '                        COM.PORT$
  1052. '                        DOORS.TERMINAL.TYPE
  1053. '                        MULTI.LINK.PRESENT
  1054. '                        RBBS.BAT$
  1055. '                        REDIRECT.IO.METHOD
  1056. '
  1057. '  OUTPUT PARAMETERS  -- Q                    NUMBER OF LINES TO WRITE OUT TO
  1058. '                                             RCTTY.BAT$
  1059. '                        B$()                 LINES TO WRITE OUT TO RCTTY.BAT$
  1060. '
  1061. '  SUBROUTINE PURPOSE -- SET UP B$() AND Q IN ORDER TO CALL "RBBSEXIT" AND
  1062. '                        EXIT TO DOS FOR THE REMOTE RBBS-PC SYSOP
  1063. '
  1064.       SUB DOSEXIT STATIC
  1065. 10934 IF MULTI.LINK.PRESENT AND _
  1066.          DOORS.TERMINAL.TYPE > 0 THEN _
  1067.          FF = 0 : _
  1068.          GOTO 10950
  1069.       A$(1) = "ECHO OFF"
  1070.       IF REDIRECT.IO.METHOD THEN _
  1071.          FF = 5 : _
  1072.          A$(2) = "CTTY " + COM.PORT$ : _
  1073.          A$(3) = DISK.FOR.DOS$ + "COMMAND" : _
  1074.          A$(4) = "CTTY CON" : _
  1075.          A$(5) = RBBS.BAT$ _
  1076.       ELSE _
  1077.          FF = 3 : _
  1078.          A$(2) = DISK.FOR.DOS$ + "COMMAND >" + COM.PORT$ + " <" + COM.PORT$ : _
  1079.          A$(3) = RBBS.BAT$
  1080. 10950 SUBROUTINE.PARAMETER = 1
  1081.       CALL AMORPM
  1082.       CALL UPDTCALR ("Exited to DOS at " + TIM$,2)
  1083.       CALL QTPUT("RBBS-PC " + VERSION.ID$,1)
  1084.       CALL QTPUT("SYSOP in Remote Console Mode",1)
  1085.       CALL RBBSEXIT (A$(),FF)
  1086.       END SUB
  1087. ' $SUBTITLE: 'WORDINFILE -- Searches a file to find a word'
  1088. ' $PAGE
  1089. '  SUBROUTINE NAME    -- WORDINFILE
  1090. '
  1091. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1092. '                        FILNAME$      FILE TO SEARCH IN
  1093. '                        STRNG$        STRING TO SEARCH FOR
  1094. '
  1095. '  OUTPUT PARAMETERS  -- INFILE        WHETHER STRING FOUND IN FILE
  1096. '
  1097. '  SUBROUTINE PURPOSE -- SEARCHES FOR "STRNG$" IN FILE "FILNAME$."  USED TO
  1098. '                        LIMIT DOORS AND QUESTIONNAIRES TO THOSE SPECIFIED
  1099. '                        IN THEIR MENU FILES.  THE "STRNG$" IS CAPITALIZED
  1100. '                        BUT NOT THE LINES IN THE FILE, SO MUST BE EXACT
  1101. '                        CASE-SENSITIVE MATCH TO BE FOUND.  THE ONLY CHARACTER
  1102. '                        THAT CAN IMMEDIATELY PROCEED OR END A NAME TO BE
  1103. '                        FOUND MUST BE A BLANK.
  1104. '
  1105.       SUB WORDINFILE (FILNAME$,STRNG$,INFILE) STATIC
  1106. 10976 INFILE = FALSE
  1107.       CALL FINDIT (FILNAME$)
  1108.       IF NOT OK THEN _
  1109.          EXIT SUB
  1110.       X = 0
  1111.       CALL ALLCAPS (STRNG$)
  1112.       WHILE NOT EOF(2) AND X < 1
  1113.         LINE INPUT #2,A$
  1114.         Y = 1
  1115. 10978   X = INSTR(Y,A$,STRNG$)
  1116.         IF X < 1 THEN _
  1117.            GOTO 10980
  1118.         Y = X+1
  1119.         IF X>1 THEN _
  1120.            IF MID$(A$,X-1,1)<>" " THEN _
  1121.               X=0
  1122.         IF X>0 THEN _
  1123.            L = LEN(STRNG$) : _
  1124.            IF LEN(A$) >= (X+L) THEN _
  1125.               IF MID$(A$,X+L,1)<>" " THEN _
  1126.                  X=0
  1127.         IF X=0 THEN _
  1128.            GOTO 10978
  1129. 10980 WEND
  1130.       CLOSE 2
  1131.       INFILE = (X > 0)
  1132.       END SUB
  1133. ' $SUBTITLE: 'DOOREXIT -- Setup to exit to a "door"'
  1134. ' $PAGE
  1135. '  SUBROUTINE NAME    -- DOOREXIT
  1136. '
  1137. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1138. '                        MULTI.LINK.PRESENT
  1139. '                        NODE.ID$
  1140. '                        RBBS.BAT$
  1141. '                        Z$
  1142. '
  1143. '  OUTPUT PARAMETERS  -- Q                    NUMBER OF LINES TO WRITE OUT TO
  1144. '                                             RCTTY.BAT$
  1145. '                        B$()                 LINES TO WRITE OUT TO RCTTY.BAT$
  1146. '
  1147. '  SUBROUTINE PURPOSE -- SET UP B$() AND Q IN ORDER TO CALL "EXITRBBS" AND
  1148. '                        EXIT RBBS-PC TO INVOKE ANTOHER PROGRAM
  1149. '
  1150.       SUB DOOREXIT STATIC
  1151. 10987 A$(1) = DISK.FOR.DOS$+ "COMMAND /C " + Z$ + NODE.ID$
  1152.       A$(2) = RBBS.BAT$
  1153.       A$ = Z$ + " door opened at " + TIME$ + " on " + DATE$
  1154.       SUBROUTINE.PARAMETER = 5
  1155.       CALL TPUT
  1156.       CALL UPDTCALR (LEFT$(Z$,LEN(Z$)-4) + " door opened!",2)
  1157.       CALL RBBSEXIT (A$(),2)
  1158.       END SUB
  1159. ' $SUBTITLE: 'RBBSEXIT -- Setup to exit to a RBBS'
  1160. ' $PAGE
  1161. '  SUBROUTINE NAME    -- RBBSEXIT
  1162. '
  1163. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1164. '                        LINE.ARA        Array of lines to write to batch file
  1165. '                        NUM.LINES       How many lines in array
  1166. '
  1167. '  OUTPUT PARAMETERS  -- RCTTY.BAT$
  1168. '
  1169. '  SUBROUTINE PURPOSE -- TO CREATE A BATCH FILE THAT CONTROL CAN BE PASSED TO
  1170. '                        AND TO EXIT RBBS-PC WHILE STILL KEEPING CARRIER UP
  1171. '
  1172.       SUB RBBSEXIT (LINE.ARA$(1),NUM.LINES) STATIC
  1173. 10992 CLOSE 2
  1174.       IF NUM.LINES = 0 THEN _
  1175.          GOTO 10994
  1176.       OPEN "O",2,RCTTY.BAT$
  1177.       FOR I = 1 TO NUM.LINES
  1178.       IF LINE.ARA$(I) <> "" THEN _
  1179.          PRINT #2,LINE.ARA$(I)
  1180.       NEXT
  1181.       CLOSE 2
  1182. 10994 CLOSE 3
  1183.       EXIT.TO.DOORS = TRUE
  1184.       OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
  1185.       CALL MLINIT (2)
  1186. 10996 IF NOT SYSOP THEN _
  1187.          CALL UPDATEU : _
  1188.          SUBROUTINE.PARAMETER = 8 : _
  1189.          CALL FILELOCK
  1190.       CALL GETIME
  1191.       CALL UPDATEC
  1192.       CALL SAVEPROF (1)
  1193.       IF NUM.LINES = 0 THEN _
  1194.          EXIT SUB
  1195.       SYSTEM
  1196.       END SUB
  1197. ' $SUBTITLE: 'UNTILRIGHT - subroutine to ask question until answer okay'
  1198. ' $PAGE
  1199. '
  1200. '  SUBROUTINE NAME    -- UNTILRIGHT
  1201. '
  1202. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1203. '                        QUES$         QUESTION TO BE ASKED THE USER
  1204. '                        ANS$          LOCATION TO STORE THE ANSWER
  1205. '                        MIN.LEN       MINIMUM LENGTH OF ANSWER
  1206. '                        MAX.LEN       MAX LENGTH OF ANSWER
  1207. '
  1208. '  OUTPUT PARAMETERS  -- ANS$          RESPONSE TO THE QUESTION WHICH THE
  1209. '                                      CALLERS SAYS IS CORRECT
  1210. '
  1211. '  SUBROUTINE PURPOSE -- SUBROUTINE TO ASK A USER A QUESTION UNTIL THE CALLER
  1212. '                        RESPONDS THAT THE ANSWER IS CORRECT
  1213. '
  1214.       SUB UNTILRIGHT (QUES$,ANS$,MIN.LEN,MAX.LEN) STATIC
  1215. 12880 SUBROUTINE.PARAMETER = 1
  1216.       A$ = QUES$
  1217.       CALL TGET
  1218.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1219.          GOTO 12882
  1220.       IF Q=0 THEN _
  1221.          GOTO 12880
  1222.       IF LEN(B$(1))>MAX.LEN THEN _
  1223.          CALL QTPUT (STR$(MAX.LEN)+" chars max",1) :_
  1224.          GOTO 12880_
  1225.       ELSE IF LEN(B$(1)) < MIN.LEN THEN_
  1226.               CALL QTPUT (STR$(MIN.LEN)+" chars min",1) : _
  1227.               GOTO 12880
  1228.       ANS$ = B$(1)
  1229.       A$ = B$(1) + ", right (Y=[ENTER],N)"
  1230.       CALL TGET
  1231.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1232.          GOTO 12882
  1233.       IF NO THEN _
  1234.          GOTO 12880
  1235.       CALL ALLCAPS (ANS$)
  1236.       EXIT SUB
  1237. 12882 ANS$ = "GUEST"
  1238.       END SUB
  1239. ' $SUBTITLE: 'LOGERROR - subroutine to log errors to CALLERS file'
  1240. ' $PAGE
  1241. '
  1242. '  SUBROUTINE NAME    -- LOGERROR
  1243. '
  1244. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  1245. '                               ERR           ERROR NUMBER DETECTED BY BASIC
  1246. '                               ERL           LAST LINE NUMBER ENCOUNTERED
  1247. '                                             PRIOR TO ENCOUNTERNING ERROR
  1248. '
  1249. '  OUTPUT PARAMETERS  -- NONE
  1250. '
  1251. '  SUBROUTINE PURPOSE -- TO SET UP A STRING TO WRITE TO THE CALLERS LOG
  1252. '                        INDICATING THE DATE, TIME, ERROR, AND ERROR LINE
  1253. '
  1254.       SUB LOGERROR STATIC
  1255. 13660 CALL UPDTCALR("+++ Error " + _
  1256.            STR$(ERR) + _
  1257.            " line " + _
  1258.            STR$(ERL) + _
  1259.            " at " + _
  1260.            TIME$ + _
  1261.            " on " + _
  1262.            DATE$,2)
  1263.       END SUB
  1264. ' $SUBTITLE: 'BADNAME - subroutine to find bad file names'
  1265. ' $PAGE
  1266. '
  1267. '  SUBROUTINE NAME    -- BADNAME
  1268. '
  1269. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  1270. '                        ACTIVE.MESSAGE.FILE$
  1271. '                        ACTIVE.USER.FILE$
  1272. '                        CALLERS.FILE$
  1273. '                        COMMENTS.FILE$
  1274. '                        CONFIG.FILEANAME$
  1275. '                        MAIN.MESSAGE.BACKUP$
  1276. '                        MAIN.MESSAGE.FILE$
  1277. '                        MAXIMUM.VIOLATIONS
  1278. '                        PASSWORDS.FILE$
  1279. '                        RBBS.BAT$
  1280. '                        RCTTY.BAT$
  1281. '                        SUBDIR$()
  1282. '                        SUBDIR.INDEX
  1283. '                        VIOLATION$
  1284. '                        VIOLATIONS.THIS.SESSION
  1285. '                        Z$                          NAME OF FILE
  1286. '
  1287. '  OUTPUT PARAMETERS  -- BAD.FILE.NAME.INDEX         1 = FILE NAME IS OK
  1288. '                                                    2 = SECURITY BREACH TRIED
  1289. '                        VIOLATIONS.THIS.SESSION     NUMBER OF VIOLATIONS
  1290. '                        FILENAME$                   NAME OF FILE
  1291. '
  1292. '  SUBROUTINE PURPOSE -- TO PROTECT RBBS-PC AGAINST THE USE OF BAD FILE NAMES
  1293. '                        TO EITHER CRASH THE SYSTEM OR TO BREACH RBBS-PC'S
  1294. '                        SECURITY
  1295. '
  1296.       SUB BADNAME (BAD.FILE.NAME.INDEX) STATIC                       ' CPC15-1B
  1297. '
  1298. ' *****************************************************************************
  1299. ' *  TEST FOR SYSTEM FILE ATTEMPT                                             *
  1300. ' *****************************************************************************
  1301. '
  1302. 20235 BAD.FILE.NAME.INDEX = 1
  1303.       Z$ = FILE.NAME$
  1304.       IF INSTR(3,FILE.NAME$,MID$(ACTIVE.MESSAGE.FILE$,3,(LEN(ACTIVE.MESSAGE.FILE$)-2))) THEN _
  1305.          GOTO 20236
  1306.       IF INSTR(3,FILE.NAME$,MID$(ACTIVE.USER.FILE$,3,(LEN(ACTIVE.USER.FILE$)-2))) THEN _
  1307.          GOTO 20236
  1308.       IF INSTR(3,FILE.NAME$,MID$(ACTIVE.USER.FILE$+".BAK",3,(LEN(ACTIVE.USER.FILE$+".BAK")-2))) THEN _
  1309.          GOTO 20236
  1310.       IF INSTR(3,FILE.NAME$,MID$(CALLERS.FILE$,3,(LEN(CALLERS.FILE$)-2))) THEN _
  1311.          GOTO 20236
  1312.       IF INSTR(3,FILE.NAME$,MID$(COMMENTS.FILE$,3,(LEN(COMMENTS.FILE$)-2))) THEN _
  1313.          GOTO 20236
  1314.       IF INSTR(3,FILE.NAME$,MID$(FILESEC.FILE$,3,(LEN(FILESEC.FILE$)-2))) THEN _
  1315.          GOTO 20236
  1316.       IF INSTR(3,FILE.NAME$,MID$(MAIN.MESSAGE.BACKUP$,3,(LEN(MAIN.MESSAGE.BACKUP$)-2))) THEN _
  1317.          GOTO 20236
  1318.       IF INSTR(3,FILE.NAME$,MID$(MAIN.MESSAGE.FILE$,3,(LEN(MAIN.MESSAGE.FILE$)-2))) THEN _
  1319.          GOTO 20236
  1320.       IF INSTR(3,FILE.NAME$,MID$(MAIN.USER.FILE$,3,(LEN(MAIN.USER.FILE$)-2))) THEN _
  1321.          GOTO 20236
  1322.       IF INSTR(3,FILE.NAME$,MID$(MAIN.USER.FILE$+".BAK",3,(LEN(MAIN.USER.FILE$+".BAK")-2))) THEN _
  1323.          GOTO 20236
  1324.       IF INSTR(3,FILE.NAME$,MID$(PASSWORDS.FILE$,3,(LEN(PASSWORDS.FILE$)-2))) THEN _
  1325.          GOTO 20236
  1326.       IF INSTR(3,FILE.NAME$,MID$(RBBS.BAT$,3,(LEN(RBBS.BAT$)-2))) THEN _
  1327.          GOTO 20236
  1328.       IF INSTR(3,FILE.NAME$,MID$(RCTTY.BAT$,3,(LEN(RCTTY.BAT$)-2))) THEN _
  1329.          GOTO 20236
  1330.       CALL BRKFNAME (CONFIG.FILENAME$,DR$,PREFIX$,EXTENSION$,FALSE)
  1331.       IF INSTR(3,FILE.NAME$,MID$(CONFIG.FILENAME$,LEN(DR$)+1)) THEN _
  1332.          GOTO 20236
  1333.       EXIT SUB
  1334. 20236 BAD.FILE.NAME.INDEX = 2
  1335.       END SUB
  1336. ' $SUBTITLE: 'BRKFNAME - subroutine to split file name into components'
  1337. ' $PAGE
  1338. '
  1339. '  SUBROUTINE NAME    -- BRKFNAME
  1340. '
  1341. '  INPUT PARAMETERS   -- PARAMETER                    MEANING
  1342. '                        FILENAME$        FULL NAME OF FILE
  1343. '                        FOR.JOINING      TRUE IF WANT PARTS FORMATTED FOR
  1344. '                                           FORMING FILE NAMES
  1345. '  OUTPUT PARAMETERS  -- DRVPATH$         DRIVE AND PATH
  1346. '                        PREFIX$          PREFIX OF FILE NAME
  1347. '                        EXTENSION$       EXTENSION OF FILE NAME
  1348. '
  1349. ' (E.G. "C:\RBBS\ARCE.COM" HAS "C:\RBBS" AS DRIVE AND PATH,
  1350. '                              "ARCE"    AS PREFIX OF THE FILE NAME, AND
  1351. '                              "COM"     AS THE EXTENSION OF THE FILE NAME.
  1352. '
  1353. ' JOINED FORMAT IS C:\RBBS\,ARCE,.COM
  1354. '
  1355. '  SUBROUTINE PURPOSE -- TO BREAK A FILE NAME INTO ITS COMPONENT PARTS
  1356. '                        OF DRIVE/PATH, PREFIX, AND EXTENSION
  1357. '
  1358. '
  1359.       SUB BRKFNAME (FILENAME$,DRVPATH$,PREFIX$,EXTENSION$,FOR.JOINING) STATIC
  1360. 20282 CALL ALLCAPS (FILENAME$)
  1361.       DRVPATH$ = ""
  1362.       PREFIX$ = ""
  1363.       EXTENSION$ = ""
  1364.       IF LEN(FILENAME$) < 1 THEN _
  1365.          EXIT SUB
  1366.       CALL FINDLAST (FILENAME$,"\",X,Y)
  1367.       IF X < 1 THEN _
  1368.          IF MID$(FILENAME$,2,1) = ":" THEN _
  1369.             DRVPATH$ = LEFT$(FILENAME$,1): _
  1370.             S = 3 _
  1371.          ELSE S = 1 _
  1372.       ELSE DRVPATH$ = LEFT$(FILENAME$,X-1) : _
  1373.            S = X + 1
  1374.       X = INSTR(FILENAME$+".",".")
  1375.       EXTENSION$ = MID$(FILENAME$,X+1,3)
  1376.       PREFIX$ = MID$(FILENAME$,S,X-S)
  1377.       IF NOT FOR.JOINING THEN _
  1378.          EXIT SUB
  1379.       IF LEN(DRVPATH$) = 1 THEN _
  1380.          DRVPATH$ = DRVPATH$ + ":"
  1381.       IF INSTR(DRVPATH$,"\") > 0 THEN _
  1382.          DRVPATH$ = DRVPATH$ + "\"
  1383.       IF LEN(EXTENSION$) > 0 THEN _
  1384.          EXTENSION$ = "." + EXTENSION$
  1385.       END SUB
  1386. ' $SUBTITLE: 'WILDCARD -- Matches string to a pattern'
  1387. ' $PAGE
  1388. '  SUBROUTINE NAME    -- WILDCARD
  1389. '
  1390. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1391. '                        PATTERN$           PATTERN TO CHECK
  1392. '                        STRNG$             STRING TO FIE
  1393. '
  1394. '  OUTPUT PARAMETERS  -- OK                 TRUE IF MATCH FOUND
  1395. '                                           FALSE IF NO MATCH WAS FOUND
  1396. '
  1397. '  SUBROUTINE PURPOSE  DETERMINE WHETHER A STRING IS AN INSTANCE IN A PATTERN
  1398. '                      SUPPORTED PATTERNS ARE ONLY "?" WHICH REQUIRES A
  1399. '                      CHARACTER BUT CAN BE ANY, AND "*" WHICH MATCHES ANY-
  1400. '                      THING, INCLUDING A NULL STRING.  ANYTHING ELSE IN A
  1401. '                      MUST BE AN EXACT MATCH.
  1402. '
  1403.       SUB WILDCARD (PATTERN$,STRNG$) STATIC
  1404. 20285 OK = TRUE
  1405.       K = 0
  1406.       L = LEN(STRNG$)
  1407. 20286 K = K + 1
  1408.       IF K > L THEN _
  1409.          GOTO 20288
  1410.       B$ = MID$(PATTERN$,K,1)
  1411.       IF B$ = "*" THEN _
  1412.          EXIT SUB
  1413. 20287 IF B$ <> "?" AND MID$(STRNG$,K,1) <> B$ THEN _
  1414.      OK = FALSE : _
  1415.          EXIT SUB
  1416.       GOTO 20286
  1417. 20288 IF L < LEN(PATTERN$) AND MID$(PATTERN$,L + 1,1) <> "*" THEN _
  1418.      OK = FALSE
  1419.       END SUB
  1420. ' $SUBTITLE: 'UPDTUPLOAD -- Updates upload directory'
  1421. ' $PAGE
  1422. '  SUBROUTINE NAME    -- UPDTUPLOAD
  1423. '
  1424. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  1425. '                        FILE.NAME$
  1426. '                        UPLOAD.DIRECTORY$
  1427. '                        FILE.NAME.HOLD$
  1428. '                        SHARE.IT
  1429. '                        FMS.DIRECTORY$
  1430. '                        Q!
  1431. '                        TCA!
  1432. '
  1433. '  OUTPUT PARAMETERS  -- BYTES.IN.FILE#
  1434. '                        SECONDS.PER.SESSION!
  1435. '
  1436. '  SUBROUTINE PURPOSE -- UPON A SUCCESSFUL UPLOAD, ADD ENTRY TO THE UPLOAD
  1437. '                        DIRECTORY AND GIVE ANY SESSION TIME CREDIT.
  1438. '
  1439.       SUB UPDTUPLOAD (CATEGORY.NAME$(1),CATEGORY.CODE$(1)) STATIC
  1440. 20705 CALL FINDIT (FILE.NAME$)
  1441.       IF NOT OK THEN _
  1442.          BYTES.IN.FILE# = 0.0_
  1443.       ELSE_
  1444.          BYTES.IN.FILE# = LOF(2)
  1445.       IF BYTES.IN.FILE# < 1.0 THEN _
  1446.          EXIT SUB
  1447.       CALL QTPUT("Upload successful",1)
  1448.       X$ = DATE$
  1449.       Z$ = LEFT$(X$,6) + RIGHT$(X$,2)
  1450.       STREW.TO$ = ""
  1451.       Y$ = ""
  1452. 20710 CALL QTPUT("Describe " + FILE.NAME.HOLD$ + _
  1453.            " (/ if for SYSOP only)",1)
  1454.       CALL QTPUT(LEFT$(" |----+---1+0---+---2+0---+---3+0---+---4+0---+-",_
  1455.                  MAX.DESC.LEN+3),1)
  1456.       A$=""
  1457.       SUBROUTINE.PARAMETER = 1
  1458.       CALL TGET
  1459.       CALL CARRIER
  1460.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1461.          B$(1) = "<description unavailable>": _                      ' CPC15-1B
  1462.          GOTO 20712
  1463.       IF LEN(B$(1)) > MAX.DESC.LEN OR LEN(B$(1)) < 10 THEN _         ' CPC15-1B
  1464.          GOTO 20710
  1465. 20712 B$ = B$(1)
  1466.       DESC$ = B$
  1467.       IF FMS.DIRECTORY$ <> UPLOAD.DIRECTORY$ THEN _
  1468.          IF LEFT$(B$,1) = "/" THEN _
  1469.             CALL UPDTCALR (B$,2) : _
  1470.             GOTO 20726_
  1471.          ELSE_
  1472.             GOTO 20717
  1473. 20715 IF LEFT$(B$,1) = "/" THEN _
  1474.          B$ = MID$(B$(1),2) : _
  1475.          Y$ = "***" : _
  1476.          GOTO 20722
  1477.       Y$ = DEFAULT.CATEGORY.CODE$
  1478. 20717 IF SUBROUTINE.PARAMETER = -1 OR _
  1479.          USER.SECURITY.LEVEL < SL.CATEGORIZE.UPLOADS THEN _
  1480.          GOTO 20722
  1481. 20719 CALL BUFFILE (UPCAT.HELP$)
  1482. 20720 A$ = "Upload best fits what category (H=help)"
  1483.       SUBROUTINE.PARAMETER = 1
  1484.       CALL TGET
  1485.       IF SUBROUTINE.PARAMETER = -1 THEN _
  1486.          B$ = DEFAULT.CATEGORY.CODE$ : _
  1487.          GOTO 20722
  1488.       IF Q = 0 THEN _
  1489.          GOTO 20719
  1490.       CALL ALLCAPS (B$(1))
  1491.       IF B$(1) = "H" THEN _
  1492.          GOTO 20719
  1493.       CALL CHKNARY (B$(1),CATEGORY.NAME$(),NUM.CATEGORIES,FOUND)
  1494.       IF FOUND>0 THEN _
  1495.          Y$ = CATEGORY.CODE$(FOUND) : _
  1496.          IF LEN(Y$) > 0 AND LEN(Y$) < 4 AND INSTR(Y$,",")=0 THEN _
  1497.             GOTO 20722
  1498.       Y$ = ""
  1499.       IF NOT LIMIT.SEARCH.TO.FMS THEN _
  1500.          STREW.TO$ = DIRECTORY.PATH$ + B$(1) + "." + DIRECTORY.EXTENTION$ : _
  1501.          CALL FINDIT (STREW.TO$) : _
  1502.          IF NOT OK THEN _
  1503.             STREW.TO$ = "" _                                         ' CPC15-1B
  1504.          ELSE GOTO 20722                                             ' CPC15-1B
  1505.       CALL QTPUT ("No such category "+B$(1),1)
  1506.       GOTO 20719
  1507. 20722 B$ = DESC$
  1508.       EN$ = ALWAYS.STREW.TO$
  1509.       GOSUB 20730
  1510.       EN$ = STREW.TO$
  1511.       GOSUB 20730
  1512. 20725 EN$ = UPLOAD.DIRECTORY$
  1513.       IF FMS.DIRECTORY$ = UPLOAD.DIRECTORY$ THEN _
  1514.          B$ = DESC$ + SPACE$(MAX.DESC.LEN-LEN(DESC$)) + Y$ + SPACE$(3-LEN(Y$))
  1515.       GOSUB 20730
  1516. 20726 Y$ = " >> uploaded << "
  1517.       UPLOADS = UPLOADS + 1
  1518.       CALL MUSIC (7)
  1519.       CALL TIMEREMAIN (TIME.REMAINING!)
  1520.       SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + _
  1521.                              UPLOAD.TIME.FACTOR! * _
  1522.                              (TCA!-Q!)
  1523.       EXIT SUB
  1524. 20730 '          ---[ lock file ]---
  1525.       IF EN$ = "" THEN _
  1526.          RETURN
  1527.       BX = &H4
  1528.       SUBROUTINE.PARAMETER = 9
  1529.       CALL FILELOCK
  1530.       CLOSE 2
  1531.       IF SHARE.IT THEN _
  1532.          OPEN EN$ FOR APPEND SHARED AS #2 _
  1533.       ELSE OPEN "A",2,EN$
  1534.       '          ---[ append ]---
  1535.       PRINT #2,USING "\           \########  &  &"; _
  1536.                      FILE.NAME.HOLD$; _
  1537.                      BYTES.IN.FILE#; _
  1538.                      Z$; _
  1539.                      B$
  1540.       CLOSE 2
  1541.       '          ---[ unlock ]---
  1542.       BX = &H4
  1543.       SUBROUTINE.PARAMETER = 10
  1544.       CALL FILELOCK
  1545.       RETURN
  1546.       END SUB
  1547. ' $SUBTITLE: 'BADFILE - subroutine to find bad file names'
  1548. ' $PAGE
  1549. '
  1550. '  SUBROUTINE NAME    -- BADFILE
  1551. '
  1552. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  1553. '                        VIOLATION$
  1554. '                        VIOLATIONS.THIS.SESSION
  1555. '                        FILNAME$                      NAME OF FILE
  1556. '
  1557. '  OUTPUT PARAMETERS  -- RESULT                      1 = FILE NAME IS OK
  1558. '                                                    2 = CHARACTER NOT ALLOWED
  1559. '                                                    3 = SYSTEM CRASH ATTEMPT
  1560. '                        VIOLATIONS.THIS.SESSION     NUMBER OF VIOLATIONS
  1561. '                        FILNAME$                    Gets capitalized
  1562. '
  1563. '  SUBROUTINE PURPOSE -- TO PROTECT RBBS-PC AGAINST THE USE OF BAD FILE NAMES
  1564. '                        TO EITHER CRASH THE SYSTEM OR TO BREACH RBBS-PC'S
  1565. '                        SECURITY
  1566. '
  1567.       SUB BADFILE (FILNAME$,RESULT) STATIC
  1568. '
  1569. ' *****************************************************************************
  1570. ' *  TEST FOR INVALID CHARACTERS IN FILENAME                                  *
  1571. ' *****************************************************************************
  1572. '
  1573. 20741 RESULT = 1
  1574.       IF LEN(FILNAME$) < 1 THEN _
  1575.          RESULT = 2 : _
  1576.          EXIT SUB
  1577.       CALL ALLCAPS (FILNAME$)
  1578.       IF INSTR(FILNAME$,"?") OR _
  1579.          INSTR(FILNAME$,"*") OR _
  1580.          INSTR(FILNAME$," ") OR _
  1581.          INSTR(3,FILNAME$,":") OR _
  1582.          INSTR(FILNAME$,".DEF") OR _
  1583.          INSTR(FILNAME$,".OLD") OR _
  1584.          MID$(FILNAME$,LEN(FILNAME$),1) = "." THEN _
  1585.            RESULT = 2 : _
  1586.            EXIT SUB
  1587.       FF = INSTR(FILNAME$,".")
  1588.       IF FF > 0 THEN _
  1589.          FF = INSTR(FF+1,FILNAME$,".") : _
  1590.          IF FF > 0 THEN _
  1591.             RESULT = 2 : _
  1592.             EXIT SUB
  1593.       FF = LEN(FILNAME$)
  1594.       IF FF >= 3 THEN _
  1595.          IF INSTR("PRN:CON:AUX:NUL:",FILNAME$) THEN _
  1596.             GOTO 20742
  1597.       IF FF >= 4 THEN _
  1598.          IF INSTR("COM1:COM2:LPT1:LPT2:LPT3:SCRN:KYBD:CONS:",FILNAME$) THEN _
  1599.             GOTO 20742
  1600.       IF FF > 12 THEN _
  1601.          RESULT = 2
  1602.       FG = INSTR(FILNAME$,".")
  1603.       IF FG = 0 AND FF > 8 THEN _
  1604.          RESULT = 2 _
  1605.       ELSE IF FG > 9 THEN _
  1606.               RESULT = 2
  1607.       EXIT SUB
  1608. 20742 VIOLATIONS.THIS.SESSION = MAXIMUM.VIOLATIONS
  1609.       VIOLATION$ = VIOLATION$ + FILNAME$
  1610.       RESULT = 3
  1611.       END SUB
  1612. ' $SUBTITLE: 'FILELOCK - subroutine to share RBBS-PC files'
  1613. ' $PAGE
  1614. '
  1615. '  SUBROUTINE NAME    -- FILELOCK
  1616. '
  1617. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  1618. '                        SUBROUTINE.PARAMETER = 1 UNLOCK USERS AND MESSAGES
  1619. '                                               2 FLUSH MESSAGE RECORD TO DISK
  1620. '                                                 AND UNLOCK MESSAGES
  1621. '                                               3 LOCK MESSAGE FILE
  1622. '                                               4 UNLOCK MESSAGE FILE
  1623. '                                               5 LOCK USER FILE
  1624. '                                               6 LOCK 4 RECORD BLOCK IN USER
  1625. '                                                 FILE
  1626. '                                               7 UNLOCK USER FILE
  1627. '                                               8 UNLOCK 4 RECORD BLOCK IN USER
  1628. '                                                 FILE
  1629. '                                               9 LOCK UPLOAD DIRECTORY OR
  1630. '                                                 COMMENTS FILE
  1631. '                                              10 UNLOCK UPLOAD DIRECTORY OR
  1632. '                                                 COMMENTS FILE
  1633. '                        ACTIVE.MESSAGE FILE$   NAME OF MESSAGE FILE
  1634. '                        ACTIVE.USER.FILE$      NAME OF USER FILE
  1635. '                        CONFIG.FILE.NAME$      FILE NAME TO FLUSH RECORD FROM
  1636. '                        EN$                    UPLOAD DIRECTORY OR COMMENTS
  1637. '                                               FILE NAME TO LOCK/UNLOCK
  1638. '                        NETWORK.TYPE           TYPE OF NETWORK LOCKING TO USE
  1639. '
  1640. '  OUTPUT PARAMETERS  -- SUBROUTINE.PARAMETER = -1 TERMINATE RBBS-PC IMMEDATELY
  1641. '                        BLK
  1642. '                        LOCK.DRIVE
  1643. '                        LOCK.FILE.NAME$
  1644. '                        LOCK.STATUS$
  1645. '                        MESSAGE.FILE.LOCK
  1646. '                        USER.BLOCK.LOCK
  1647. '                        USER.FILE.LOCK
  1648. '                        USER.FILE.INDEX
  1649. '
  1650. '  SUBROUTINE PURPOSE -- TO LOCK AND UNLOCK THE SHARED RBBS-PC FILES WHEN
  1651. '                        MULTIPLE COPIES OF RBBS-PC ARE SHARING THE SAME
  1652. '                        FILES IN EITHER A MULTI-TASKING DOS ENVIRONMENT OR
  1653. '                        IN A LOCAL AREA NETWORK ENVIRONMENT
  1654.       SUB FILELOCK STATIC
  1655.       ON SUBROUTINE.PARAMETER GOSUB 21995,21996,22000,25000,26000,26500,27000,_
  1656.                                     27500,29000,29500
  1657.       EXIT SUB
  1658. '
  1659. ' *****************************************************************************
  1660. ' *  UNLOCK USERS AND MESSAGES                                                *
  1661. ' *****************************************************************************
  1662. '
  1663. 21995 GOSUB 27000
  1664.       GOSUB 25000
  1665.       RETURN
  1666. '
  1667. ' *****************************************************************************
  1668. ' *  FLUSH MESSAGE FILE DATA TO DISK BY OPENING DUMMY FILE # 1                *
  1669. ' *****************************************************************************
  1670. '
  1671. 21996 CLOSE 1
  1672.       IF SHARE.IT THEN _
  1673.          OPEN CONFIG.FILENAME$ FOR INPUT SHARED AS #1 _
  1674.          ELSE OPEN "I",1,CONFIG.FILENAME$
  1675.       CLOSE 1
  1676. '
  1677. ' *****************************************************************************
  1678. ' *  UNLOCK MESSAGES                                                          *
  1679. ' *****************************************************************************
  1680. '
  1681.       GOSUB 25000
  1682.       RETURN
  1683. '
  1684. ' *****************************************************************************
  1685. ' *  LOCK MESSAGE FILE                                                        *
  1686. ' *****************************************************************************
  1687. '
  1688. 22000 IF MESSAGE.FILE.LOCK = TRUE THEN _
  1689.          RETURN
  1690.       MESSAGE.FILE.LOCK = TRUE
  1691.       MID$(LOCK.STATUS$,1,2) = "LM"
  1692.       SUBROUTINE.PARAMETER = 2
  1693.       CALL LINE25
  1694.       LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$
  1695.       ON NETWORK.TYPE GOTO 22100,22200,22300,22400,22500
  1696.       RETURN
  1697. '
  1698. ' *****************************************************************************
  1699. ' *  LOCK MESSAGE FILE (MULTI-LINK)                                           *
  1700. ' *****************************************************************************
  1701. '
  1702. 22100 AX = &H0
  1703.       BX = &H1
  1704.       CALL RBBSML(AX,BX)
  1705.       RETURN
  1706. '
  1707. ' *****************************************************************************
  1708. ' *  LOCK MESSAGE FILE (OMNINET)                                              *
  1709. ' *****************************************************************************
  1710. '
  1711. 22200 CC$ = CHR$(1) + MID$(ACTIVE.MESSAGE.FILE$ + SPACE$(8),3,8)
  1712.       GOSUB 28000
  1713.       IF CT = 0 THEN _
  1714.          RETURN
  1715.       CALL DELAYIT (1)
  1716.       GOTO 22200
  1717. '
  1718. ' *****************************************************************************
  1719. ' *  LOCK MESSAGE FILE (ORCHID PC-NET)                                        *
  1720. ' *  LOCK USER FILE (ORCHID PC-NET)                                           *
  1721. ' *  LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET)           *
  1722. ' *****************************************************************************
  1723. '
  1724. 22300 GOSUB 28100
  1725.       CALL LPLKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A)
  1726.       RETURN
  1727. '
  1728. ' *****************************************************************************
  1729. ' *  LOCK SYSTEM (DESQview)                                                   *
  1730. ' *****************************************************************************
  1731. '
  1732. 22400 AX = 1
  1733.       BX = 0
  1734.       CALL RBBSDV(AX,BX)
  1735.       RETURN
  1736. '
  1737. ' *****************************************************************************
  1738. ' *  LOCK MESSAGE FILE (10 NET)                                               *
  1739. ' *  LOCK USER FILE (10 NET)                                                  *
  1740. ' *  LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET)                  *
  1741. ' *****************************************************************************
  1742. '
  1743. 22500 GOSUB 28100
  1744.       CALL LPLK10(LOCK.DRIVE,LOCK.FILE.NAME$,A)
  1745.       RETURN
  1746. '
  1747. ' *****************************************************************************
  1748. ' *  UNLOCK MESSAGE FILE                                                      *
  1749. ' *****************************************************************************
  1750. '
  1751. 25000 MESSAGE.FILE.LOCK = FALSE
  1752.       MID$(LOCK.STATUS$,1,2) = "UM"
  1753.       SUBROUTINE.PARAMETER = 2
  1754.       CALL LINE25
  1755.       LOCK.FILE.NAME$ = ACTIVE.MESSAGE.FILE$
  1756.       ON NETWORK.TYPE GOTO 25100,25200,25300,25400,25500
  1757.       RETURN
  1758. '
  1759. ' *****************************************************************************
  1760. ' *  UNLOCK MESSAGE FILE (MULTI-LINK)                                         *
  1761. ' *****************************************************************************
  1762. '
  1763. 25100 AX = &H100
  1764.       BX = &H1
  1765.       CALL RBBSML(AX,BX)
  1766.       RETURN
  1767. '
  1768. ' *****************************************************************************
  1769. ' *  UNLOCK MESSAGE FILE (OMNINET)                                            *
  1770. ' *****************************************************************************
  1771. '
  1772. 25200 CC$ = CHR$(17) + MID$(ACTIVE.MESSAGE.FILE$ + SPACE$(8),3,8)
  1773.       GOSUB 28000
  1774.       IF CT = 128 THEN _
  1775.          RETURN
  1776.       CALL DELAYIT (1)
  1777.       GOTO 25200
  1778. '
  1779. ' *****************************************************************************
  1780. ' *  UNLOCK MESSAGE FILE (ORCHID PC-NET)                                      *
  1781. ' *  UNLOCK USER FILE (ORCHID PC-NET)                                         *
  1782. ' *  UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (ORCHID PC-NET)         *
  1783. ' *****************************************************************************
  1784. '
  1785. 25300 GOSUB 28100
  1786.       CALL UNLOKIT(LOCK.DRIVE,LOCK.FILE.NAME$,A)
  1787.       RETURN
  1788. '
  1789. ' *****************************************************************************
  1790. ' *  UNLOCK SYSTEM (DESQview)                                                 *
  1791. ' *****************************************************************************
  1792. '
  1793. 25400 AX = 2
  1794.       BX = 0
  1795.       CALL RBBSDV(AX,BX)
  1796.       RETURN
  1797. '
  1798. ' *****************************************************************************
  1799. ' *  UNLOCK MESSAGE FILE (10 NET)                                             *
  1800. ' *  UNLOCK USER FILE (10 NET)                                                *
  1801. ' *  UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (10 NET)                *
  1802. ' *****************************************************************************
  1803. '
  1804. 25500 GOSUB 28100
  1805.       CALL UNLOK10(LOCK.DRIVE,LOCK.FILE.NAME$,A)
  1806.       RETURN
  1807.  
  1808. '
  1809. ' *****************************************************************************
  1810. ' *  LOCK USER FILE                                                           *
  1811. ' *****************************************************************************
  1812. '
  1813. 26000 IF USER.FILE.LOCK = TRUE THEN _
  1814.          RETURN
  1815.       USER.FILE.LOCK = TRUE
  1816.       MID$(LOCK.STATUS$,4,2) = "LU"
  1817.       SUBROUTINE.PARAMETER = 2
  1818.       CALL LINE25
  1819.       LOCK.FILE.NAME$ = ACTIVE.USER.FILE$
  1820.       ON NETWORK.TYPE GOTO 26100,26200,22300,22400,22500
  1821.       RETURN
  1822. '
  1823. ' *****************************************************************************
  1824. ' *  LOCK USER FILE (MULTI-LINK)                                              *
  1825. ' *****************************************************************************
  1826. '
  1827. 26100 AX = &H0
  1828.       BX = &H2
  1829.       CALL RBBSML(AX,BX)
  1830.       RETURN
  1831. '
  1832. ' *****************************************************************************
  1833. ' *  LOCK USER FILE (OMNINET)                                                 *
  1834. ' *****************************************************************************
  1835. '
  1836. 26200 CC$ = CHR$(1) + MID$(ACTIVE.USER.FILE$ + SPACE$(8),3,8)
  1837.       GOSUB 28000
  1838.       IF CT = 0 THEN _
  1839.          RETURN
  1840.       CALL DELAYIT (1)
  1841.       GOTO 26200
  1842. '
  1843. ' *****************************************************************************
  1844. ' *  LOCK 4 RECORD BLOCK IN USER FILE                                         *
  1845. ' *****************************************************************************
  1846. '
  1847. 26500 IF USER.BLOCK.LOCK = TRUE THEN _
  1848.          RETURN
  1849.       USER.BLOCK.LOCK = TRUE
  1850.       BLK = (USER.FILE.INDEX / 4) + .26
  1851.       MID$(LOCK.STATUS$,7,2) = "LB"
  1852.       SUBROUTINE.PARAMETER = 2
  1853.       CALL LINE25
  1854.       ON NETWORK.TYPE GOTO 26600,26700,26800,22400,26900
  1855.       RETURN
  1856. '
  1857. ' *****************************************************************************
  1858. ' *  LOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK)                            *
  1859. ' *****************************************************************************
  1860. '
  1861. 26600 AX = &H0
  1862.       BX = BLK + 10
  1863.       CALL RBBSML(AX,BX)
  1864.       RETURN
  1865. '
  1866. ' *****************************************************************************
  1867. ' *  LOCK 4 RECORD BLOCK IN USER FILE (OMNINET)                               *
  1868. ' *****************************************************************************
  1869. '
  1870. 26700 CC$ = CHR$(1) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1871.       GOSUB 28000
  1872.       IF CT = 0 THEN _
  1873.          RETURN
  1874.       CALL DELAYIT (1)
  1875.       GOTO 26700
  1876. '
  1877. ' *****************************************************************************
  1878. ' *  LOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET)                         *
  1879. ' *****************************************************************************
  1880. '
  1881. 26800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1882.       GOTO 22300
  1883. '
  1884. ' *****************************************************************************
  1885. ' *  LOCK 4 RECORD BLOCK IN USER FILE (10 NET)                                *
  1886. ' *****************************************************************************
  1887. '
  1888. 26900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1889.       GOTO 22500
  1890. '
  1891. ' *****************************************************************************
  1892. ' *  UNLOCK USER FILE                                                         *
  1893. ' *****************************************************************************
  1894. '
  1895. 27000 USER.FILE.LOCK = FALSE
  1896.       MID$(LOCK.STATUS$,4,2) = "UU"
  1897.       SUBROUTINE.PARAMETER = 2
  1898.       CALL LINE25
  1899.       LOCK.FILE.NAME$ = ACTIVE.USER.FILE$
  1900.       ON NETWORK.TYPE GOTO 27100,27200,25300,25400,25500
  1901.       RETURN
  1902. '
  1903. ' *****************************************************************************
  1904. ' *  UNLOCK USER FILE (MULTI-LINK)                                            *
  1905. ' *****************************************************************************
  1906. '
  1907. 27100 AX = &H100
  1908.       BX = &H2
  1909.       CALL RBBSML(AX,BX)
  1910.       RETURN
  1911. '
  1912. ' *****************************************************************************
  1913. ' *  UNLOCK USER FILE (OMNINET)                                               *
  1914. ' *****************************************************************************
  1915. '
  1916. 27200 CC$ = CHR$(17) + MID$(ACTIVE.USER.FILE$ + SPACE$(8),3,8)
  1917.       GOSUB 28000
  1918.       IF CT = 128 THEN _
  1919.          RETURN
  1920.       CALL DELAYIT (1)
  1921.       GOTO 27200
  1922.  
  1923. '
  1924. ' *****************************************************************************
  1925. ' *  UNLOCK 4 RECORD BLOCK IN USER FILE                                       *
  1926. ' *****************************************************************************
  1927. '
  1928. 27500 USER.BLOCK.LOCK = FALSE
  1929.       BLK = (USER.FILE.INDEX / 4) + .26
  1930.       MID$(LOCK.STATUS$,7,2) = "UB"
  1931.       SUBROUTINE.PARAMETER = 2
  1932.       CALL LINE25
  1933.       ON NETWORK.TYPE GOTO 27600,27700,27800,25400,27900
  1934.       RETURN
  1935. '
  1936. ' *****************************************************************************
  1937. ' *  UNLOCK 4 RECORD BLOCK IN USER FILE (MULTI-LINK)                          *
  1938. ' *****************************************************************************
  1939. '
  1940. 27600 AX = &H100
  1941.       BX = BLK + 10
  1942.       CALL RBBSML(AX,BX)
  1943.       RETURN
  1944. '
  1945. ' *****************************************************************************
  1946. ' *  UNLOCK 4 RECORD BLOCK IN USER FILE (OMNINET)                             *
  1947. ' *****************************************************************************
  1948. '
  1949. 27700 CC$ = CHR$(17) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1950.       GOSUB 28000
  1951.       IF CT = 128 THEN _
  1952.          RETURN
  1953.       CALL DELAYIT (1)
  1954.       GOTO 27700
  1955. '
  1956. ' *****************************************************************************
  1957. ' *  UNLOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET)                       *
  1958. ' *****************************************************************************
  1959. '
  1960. 27800 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1961.       GOTO 25300
  1962. '
  1963. ' *****************************************************************************
  1964. ' *  UNLOCK 4 RECORD BLOCK IN USER FILE (ORCHID PC-NET)                       *
  1965. ' *****************************************************************************
  1966. '
  1967. 27900 LOCK.FILE.NAME$ = LEFT$(ACTIVE.USER.FILE$,2) + "BLK" + RIGHT$("0000" + MID$(STR$(BLK),2),5)
  1968.       GOTO 25500
  1969. '
  1970. ' *****************************************************************************
  1971. ' *  CORVUS OMNINET INTERFACE                                                 *
  1972. ' *****************************************************************************
  1973. '
  1974. 28000 CC$ = LINE.FEED$ + CHR$(0) + CHR$(11) + CC$
  1975.       CALL CDSEND(CC$)
  1976.       CALL CDRECV(CN$)
  1977.       CT = ASC(MID$(CN$,3,1))
  1978.       IF CT >= 128 THEN _
  1979.          PRINT "CORVUS LOCK FAIL" : _
  1980.          SUBROUTINE.PARAMETER = -1
  1981. 28010 CT = ASC(MID$(CN$,4,1))
  1982.       IF CT >= 129 THEN _
  1983.          PRINT "CORVUS FULL" : _
  1984.          SUBROUTINE.PARAMETER = -1
  1985.       RETURN
  1986. '
  1987. ' *****************************************************************************
  1988. ' *  ORCHID PC-NET & 10 NET INTERFACE                                         *
  1989. ' *****************************************************************************
  1990. '
  1991. 28100 CALL ALLCAPS (LOCK.FILE.NAME$)
  1992.       LOCK.DRIVE = ASC(LEFT$(LOCK.FILE.NAME$,1))-ASC("A")
  1993.       LOCK.FILE.NAME$ = LOCK.FILE.NAME$ + _
  1994.                         STRING$(32-LEN(LOCK.FILE.NAME$),0)
  1995.       A = 0
  1996.       RETURN
  1997. '
  1998. ' *****************************************************************************
  1999. ' *  LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$                           *
  2000. ' *****************************************************************************
  2001. '
  2002. 29000 MID$(LOCK.STATUS$,10,2) = "LD"
  2003.       SUBROUTINE.PARAMETER = 2
  2004.       CALL LINE25
  2005.       LOCK.FILE.NAME$ = EN$
  2006.       ON NETWORK.TYPE GOTO 29100,29010,22300,22400,22500
  2007. 29010 RETURN
  2008. '
  2009. ' *****************************************************************************
  2010. ' *  LOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK)              *
  2011. ' *****************************************************************************
  2012. '
  2013. 29100 AX = &H0
  2014.       BX = &H3
  2015.       CALL RBBSML(AX,BX)
  2016.       RETURN
  2017. '
  2018. ' *****************************************************************************
  2019. ' *  UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$                         *
  2020. ' *****************************************************************************
  2021. '
  2022. 29500 MID$(LOCK.STATUS$,10,2) = "UD"
  2023.       SUBROUTINE.PARAMETER = 2
  2024.       CALL LINE25
  2025.       LOCK.FILE.NAME$ = EN$
  2026.       ON NETWORK.TYPE GOTO 29600,29510,25300,25400,25500
  2027. 29510 RETURN
  2028. '
  2029. ' *****************************************************************************
  2030. ' *  UNLOCK UPLOAD DIRECTORY OR COMMENTS BASED ON EN$ (MULTI-LINK)            *
  2031. ' *****************************************************************************
  2032. '
  2033. 29600 AX = &H100
  2034.       BX = &H3
  2035.       CALL RBBSML(AX,BX)
  2036.       EXIT SUB
  2037.       END SUB
  2038. ' $SUBTITLE: 'OPENMSG - open the MESSAGES file'
  2039. ' $PAGE
  2040. '
  2041. '  SUBROUTINE NAME    -- OPENMSG
  2042. '
  2043. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2044. '                         ACTIVE.MESSAGE.FILE$
  2045. '                         SHARE.IT
  2046. '
  2047. '  OUTPUT PARAMETERS  --  MESSAGE.RECORD$
  2048. '
  2049.       SUB OPENMSG STATIC
  2050. '
  2051. ' *****************************************************************************
  2052. ' *  OPEN AND DEFINE MESSAGE FILE                                             *
  2053. ' *****************************************************************************
  2054. '
  2055. 30500 CLOSE 1
  2056.       IF SHARE.IT THEN _
  2057.          OPEN ACTIVE.MESSAGE.FILE$ FOR RANDOM SHARED AS #1 _
  2058.       ELSE OPEN "R",1,ACTIVE.MESSAGE.FILE$
  2059.       FIELD 1,128 AS MESSAGE.RECORD$
  2060.       END SUB
  2061. ' $SUBTITLE: 'TIMEREMAIN - calculates time remaining in a session'
  2062. ' $PAGE
  2063. '
  2064. '  SUBROUTINE NAME    -- TIMEREMAIN
  2065. '
  2066. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2067. '                         USER.LOGON.TIME!
  2068. '                         SECONDS.PER.SESSION!
  2069. '                         BYPASS.TIME.CHECK
  2070. '  OUTPUT PARAMETERS  --     PARAMETER                    MEANING
  2071. '                         TIME.REMAINING! TIME IN MINUTES LEFT IN SESSION
  2072. '                         TCA!            TIME USED IN SECONDS
  2073.       SUB TIMEREMAIN (TIME.REMAINING!) STATIC
  2074. 41010 TOA! = FRE("A")
  2075.       IF BYPASS.TIME.CHECK THEN _
  2076.          TIME.REMAINING! = SECONDS.PER.SESSION! : _
  2077.          EXIT SUB
  2078.       CALL FINDTIME (TI!)
  2079.       IF TI! > USER.LOGON.TIME! THEN _
  2080.          CALL FINDTIME (TCA!) : _
  2081.          TCA! = TCA! - USER.LOGON.TIME! _
  2082.       ELSE CALL FINDTIME (TI!) : _
  2083.            TCA! = TI! + 86400! - USER.LOGON.TIME!
  2084.       TIME.REMAINING! = (SECONDS.PER.SESSION!-TCA!) / 60
  2085.       TIME.REMAINING! = -(TIME.REMAINING! > 0.0)*TIME.REMAINING!
  2086.       END SUB
  2087. '
  2088. ' *****************************************************************************
  2089. ' * SUBROUTINE TO CALCULATE AND DISPLAY THE TIME REAMINING                    *
  2090. ' *****************************************************************************
  2091. '
  2092.       SUB DISPLAYTR (TIME.REMAINING!) STATIC
  2093.       CALL TIMEREMAIN (TIME.REMAINING!)
  2094.       CALL QTPUT (STR$(INT(TIME.REMAINING!))+" min left",1)
  2095.       END SUB
  2096. ' $SUBTITLE: 'AMORPM - subroutine to give time of day in AM/PM format'
  2097. ' $PAGE
  2098. '
  2099. '  SUBROUTINE NAME    -- AMORPM
  2100. '
  2101. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2102. '                        SUBROUTINE.PARAMETER = 1  GET CURRENT TIME AND DATE
  2103. '                        SUBROUTINE.PARAMETER = 2  CALCULATE TIME AS AM OR PM
  2104. '
  2105. '  OUTPUT PARAMETERS  -- CURRENT.DATE$           CURRENT DATE (MM-DD-YY)
  2106. '                        TIM$                    CURRENT TIME (I.E. 1:13 PM)
  2107. '                        TIME.LOGGEND.ON$        TIME USER LOGGED ON (HH:MM:SS)
  2108. '
  2109. '  SUBROUTINE PURPOSE -- TO SET THE OUTPUT PARAMETERS AS INDICATED AND
  2110. '                        DESCRIBE THE TIME AS "AM" OR "PM."
  2111. '
  2112.       SUB AMORPM STATIC
  2113.       ON SUBROUTINE.PARAMETER GOTO 41500,41510
  2114. '
  2115. ' *****************************************************************************
  2116. ' *  CALCULATE CURRENT TIME FOR AM OR PM                                      *
  2117. ' *****************************************************************************
  2118. '
  2119. 41500 TIME.LOGGED.ON$ = TIME$
  2120.       CURRENT.DATE$ = LEFT$(DATE$ ,6) + RIGHT$(DATE$ ,2)
  2121. 41510 TIM$ = TIME$
  2122.       IF VAL(MID$(TIM$,1,2)) = 12 THEN _
  2123.          MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))),2) : _
  2124.          TIM$ = LEFT$(TIM$,5) + " PM" : _
  2125.          EXIT SUB
  2126.       IF VAL(MID$(TIM$,1,2)) > 11 THEN _
  2127.          MID$(TIM$,1,2) = RIGHT$(STR$(VAL(MID$(TIM$,1,2))-12),2) : _
  2128.          TIM$ = LEFT$(TIM$,5) + " PM" : _
  2129.          EXIT SUB
  2130.       TIM$ = LEFT$(TIM$,5) + " AM"
  2131.       END SUB
  2132. ' $SUBTITLE: 'CARRIER - subroutine to monitor carrier on comm. port'
  2133. ' $PAGE
  2134. '
  2135. '  SUBROUTINE NAME    -- CARRIER
  2136. '
  2137. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2138. '                         LOCAL.USER = 0               REMOTE USER
  2139. '                         LOCAL.USER = -1              LOCAL KEYBOARD USER
  2140. '                         MODEM.STATUS.REGISTER        ADDRESS OF THE COMMUNI-
  2141. '                                                      CATIONS PORT'S REGISTER
  2142. '                         SUBROUTINE.PARAMETER = -9    DON'T WRITE TO CALLERS
  2143. '                         SUBROUTINE.PARAMETER = -10   SAME AS -9, BUT DON'T
  2144. '                                                      DELAY
  2145. '
  2146. '  OUTPUT PARAMETERS  --  SUBROUTINE.PARAMETER = 0     CARRIER STILL PRESENT
  2147. '                         SUBROUTINE.PARAMETER = -1    CARRIER NOT PRESENT
  2148. '
  2149. '  SUBROUTINE PURPOSE --  TO TEST IF CARRIER IS PRESENT (I.E. THE USER
  2150. '                         STILL ON LINE).
  2151. '
  2152.       SUB CARRIER STATIC
  2153.       TOA! = FRE("A")
  2154.       IF SUBROUTINE.PARAMETER = -1 THEN _
  2155.          EXIT SUB
  2156.       SPEEDY = 0
  2157.       IF SUBROUTINE.PARAMETER <= -9 THEN _
  2158.      DONT.WRITE = -9
  2159.       IF SUBROUTINE.PARAMETER = -10 THEN _
  2160.      SPEEDY = -1
  2161.       SUBROUTINE.PARAMETER = 0
  2162. '
  2163. ' *****************************************************************************
  2164. ' * TEST FOR CARRIER PRESENT (DROP CALLER IF CARRIER NOT PRESENT)             *
  2165. ' *****************************************************************************
  2166. '
  2167. 42000 IF LOCAL.USER THEN _
  2168.          EXIT SUB
  2169. 42010 IF INP(MODEM.STATUS.REGISTER) > 127 THEN _
  2170.          EXIT SUB
  2171. '
  2172. ' *****************************************************************************
  2173. ' * IN CASE USER IS 2400 BAUD, PAUSE A SECOND AND CHECK AGAIN FOR CARRIER     *
  2174. ' * DETECT.  SOME 2400 BAUD MODEMS TAKE A WHILE TO SYNCHRONIZE THE CARRIER,   *
  2175. ' * HENCE A THREE-SECOND PAUSE BEFORE CHECKING AGAIN.                         *
  2176. ' *****************************************************************************
  2177. '
  2178.       IF SPEEDY = -1 THEN _
  2179.      GOTO 42020
  2180.       CALL DELAYIT (MODEM.INIT.WAIT.TIME)
  2181.       SUBROUTINE.PARAMETER = 0
  2182.       IF INP(MODEM.STATUS.REGISTER) > 127 THEN _
  2183.          EXIT SUB
  2184. 42020 SUBROUTINE.PARAMETER = -1
  2185.       IF DONT.WRITE = -9 THEN _
  2186.      DONT.WRITE = 0 : _
  2187.          EXIT SUB
  2188.       IF ALREADY.WRITTEN = -9 THEN _
  2189.          EXIT SUB
  2190.       CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
  2191.       ALREADY.WRITTEN = -9
  2192.       CALL UPDTCALR ("Carrier dropped",1)
  2193.       SUBROUTINE.PARAMETER = -1
  2194.       END SUB
  2195. '
  2196. ' $SUBTITLE: 'GRAPHIC - subroutine to find graphic version of a file'
  2197. ' $PAGE
  2198. '
  2199. '  SUBROUTINE NAME    -- GRAPHIC
  2200. '
  2201. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2202. '                            DEFAULT$          Users graphic default
  2203. '                            GR                Whether graphics avail
  2204. '                            FILE.NAME$        File to check
  2205. '
  2206. '  OUTPUT PARAMETERS  --     FILE.NAME$        Substitutes name of graphics
  2207. '                                              file if it exists
  2208. '
  2209. '  SUBROUTINE PURPOSE -- Checks whether there is a graphics version of
  2210. '                        a file, based on users graphics preference.
  2211. '                        Sets file name to graphics file if it exists,
  2212. '                        otherwise leaves file name intact.  Returns file
  2213. '                        name to use.
  2214. '
  2215.       SUB GRAPHIC (DEFAULT$) STATIC
  2216. 43031 IF GR THEN _
  2217.          CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE) : _
  2218.          IF LEN(X$) < 8 THEN _
  2219.             DF$ = DR$ + _
  2220.                   X$ + _
  2221.                   DEFAULT$ + _
  2222.                   EXTENTION$ : _
  2223.              CALL FINDIT (DF$): _
  2224.              IF OK THEN _
  2225.                 FILE.NAME$ = DF$
  2226.       END SUB
  2227. ' $SUBTITLE: 'SAVEPROF - subroutine to read a user profile'
  2228. ' $PAGE
  2229. '
  2230. '  SUBROUTINE NAME    -- SAVEPROF
  2231. '
  2232. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2233. '                        BPS
  2234. '                        EIGHT.BIT
  2235. '                        EXIT.TO.DOORS
  2236. '                        GR
  2237. '                        KERMIT.FUNCTION
  2238. '                        MESSAGE.RECORD$
  2239. '                        NODE.RECORD.INDEX
  2240. '                        SYSOP
  2241. '                        UPPER.CASE
  2242. '                        TIME.LOGGED.ON$
  2243. '                        PRIVATE.DOOR
  2244. '                        RELIABLE.MODE
  2245. '
  2246. '  OUTPUT PARAMETERS  -- NONE
  2247. '
  2248. '  SUBROUTINE PURPOSE -- SAVES A USER'S OPTIONS AND COMMUNICATIONS PARAMETERS
  2249. '                        IN THE NODE RECORD WHEN A USER EXITS TO A "DOOR" SO
  2250. '                        THAT HE IS IN THE SAME STATUS AS WHEN HE EXITED.
  2251. '
  2252.       SUB SAVEPROF(IPARM) STATIC
  2253.       ON IPARM GOTO 43070,43080
  2254. '
  2255. ' *****************************************************************************
  2256. ' *  SAVE USER PROFILE WHEN EXITING                                           *
  2257. ' *****************************************************************************
  2258. '
  2259. 43070 SUBROUTINE.PARAMETER = 3
  2260.       CALL FILELOCK
  2261.       CALL OPENMSG
  2262.       FIELD 1, 128 AS MESSAGE.RECORD$
  2263.       GET 1,NODE.RECORD.INDEX
  2264.       MID$(MESSAGE.RECORD$,40,2) = STR$(EXIT.TO.DOORS)
  2265.       MID$(MESSAGE.RECORD$,42,2) = STR$(EIGHT.BIT)
  2266.       MID$(MESSAGE.RECORD$,44,2) = STR$(BPS)
  2267.       MID$(MESSAGE.RECORD$,46,2) = STR$(UPPER.CASE)
  2268.       MID$(MESSAGE.RECORD$,48,5) = SPACE$(5)
  2269.       MID$(MESSAGE.RECORD$,53,2) = STR$(GR)
  2270.       MID$(MESSAGE.RECORD$,55,2) = STR$(SYSOP)
  2271.       MID$(MESSAGE.RECORD$,64,8) = TIME.LOGGED.ON$
  2272.       MID$(MESSAGE.RECORD$,72,2) = STR$(PRIVATE.DOOR)
  2273.       MID$(MESSAGE.RECORD$,74,2) = STR$(TRANSFER.FUNCTION)
  2274.       MID$(MESSAGE.RECORD$,91,2) = STR$(RELIABLE.MODE)
  2275. 43080 PUT 1,NODE.RECORD.INDEX
  2276.       SUBROUTINE.PARAMETER = 2
  2277.       CALL FILELOCK
  2278.       CALL OPENMSG
  2279.       END SUB
  2280. ' $SUBTITLE: 'READPROF - subroutine to restore a user profile'
  2281. ' $PAGE
  2282. '
  2283. '  SUBROUTINE NAME    -- READPROF
  2284. '
  2285. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2286. '                        NODE.RECORD.INDEX     NODE RECORD TO USE
  2287. '                        SYSOP.PASSWORD.1$     SYSOP'S PSEUDONYM 1
  2288. '                        SYSOP.PASSWORD.2$     SYSOP'S PSEUDONYM 2
  2289. '
  2290. '  OUTPUT PARAMETERS  -- USER'S OPTIONS AND COMMUNICATIONS PARAMETERS
  2291. '                        UPON EXITING RBBS-PC TO A "DOOR"
  2292. '
  2293. '  SUBROUTINE PURPOSE -- RESET A USER'S OPTIONS AND COMMUNICATIONS PARAMETERS
  2294. '                        THAT WERE SAVED IN THE NODE RECORD WHEN A USER EXITED
  2295. '                        TO A "DOOR" SO THAT HE IS IN THE SAME STATUS AS WHEN
  2296. '                        HE EXITED.
  2297. '
  2298.       SUB READPROF STATIC
  2299. '
  2300. ' *****************************************************************************
  2301. ' *  RESTORE USER PROFILE WHEN RETURNING FROM DOORS                           *
  2302. ' *****************************************************************************
  2303. '
  2304. 44000 LOCATE 24,1
  2305.       PRINT "NODE INDEX", NODE.RECORD.INDEX
  2306.       FIELD 1, 128 AS MESSAGE.RECORD$
  2307.       GET 1,NODE.RECORD.INDEX
  2308.       EIGHT.BIT = VAL(MID$(MESSAGE.RECORD$,42,2))
  2309.       RELIABLE.MODE = VAL(MID$(MESSAGE.RECORD$,91,2))
  2310.       BPS = VAL(MID$(MESSAGE.RECORD$,44,2))
  2311.       CALL COMMINFO
  2312.       BAUD.TEST = VAL(LEFT$(BAUD.PARITY$,4))
  2313.       UPPER.CASE = VAL(MID$(MESSAGE.RECORD$,46,2))
  2314.       GR = VAL(MID$(MESSAGE.RECORD$,53,2))
  2315.       SYSOP = VAL(MID$(MESSAGE.RECORD$,55,2))
  2316.       TIME.LOGGED.ON$ = MID$(MESSAGE.RECORD$,64,8)
  2317.       PRIVATE.DOOR = VAL(MID$(MESSAGE.RECORD$,72,2))
  2318.       TRANSFER.FUNCTION = VAL(MID$(MESSAGE.RECORD$,74,2))
  2319.       IF REQUIRED.RINGS > 0 AND _
  2320.          INSTR(MODEM.INIT.COMMAND$,"S0=255") THEN _
  2321.          COLOR 7,0,0 _
  2322.       ELSE COLOR FG,BG,BORDER
  2323.       IF LOCAL.USER.MODE THEN _
  2324.          GOTO 44003
  2325.       IF BPS = -1 THEN _
  2326.          BAUD.RATE.DIVISOR = &H180 + (11*(COMPUTER.TYPE = 2))
  2327.       IF BPS = -2 THEN _
  2328.          BAUD.RATE.DIVISOR = &H100 + (8*(COMPUTER.TYPE = 2))
  2329.       IF BPS = -3 THEN _
  2330.          BAUD.RATE.DIVISOR = &H60 + (3*(COMPUTER.TYPE = 2))
  2331.       IF BPS = -4 THEN _
  2332.          BAUD.RATE.DIVISOR = &H30 + (1*(COMPUTER.TYPE = 2))
  2333.       IF BPS = -5 THEN _
  2334.          BAUD.RATE.DIVISOR = &H18
  2335.       IF BPS = -6 THEN _
  2336.          BAUD.RATE.DIVISOR = &HC
  2337.       CALL SETBAUD
  2338. 44003 CALL FINDTIME (USER.LOGON.TIME!)
  2339.       IF MINUTES.PER.SESSION! < 1 THEN _
  2340.          MINUTES.PER.SESSION! = 3
  2341.       IF NOT EIGHT.BIT THEN _
  2342.          OUT LINE.CONTROL.REGISTER,&H1A
  2343.       IF SYSOP THEN _
  2344.          FIRST.NAME$ = SYSOP.PASSWORD.1$ : _
  2345.          LAST.NAME$ = SYSOP.PASSWORD.2$ : _
  2346.          ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + _
  2347.                              " " + LAST.NAME$,1,31) : _
  2348.          EXIT SUB
  2349.       FIRST.NAME.END = INSTR(MESSAGE.RECORD$," ")
  2350.       LAST.NAME.END = INSTR(FIRST.NAME.END + 1,MESSAGE.RECORD$+" ","  ") 'CPC151B6
  2351.       FIRST.NAME$ = LEFT$(MESSAGE.RECORD$,FIRST.NAME.END-1)
  2352.       LAST.NAME$ = MID$(MESSAGE.RECORD$,FIRST.NAME.END + 1,LAST.NAME.END-(FIRST.NAME.END + 1))
  2353.       ACTIVE.USER.NAME$ = MID$(FIRST.NAME$ + " " + LAST.NAME$,1,31)
  2354.       Z$ = FIRST.NAME$
  2355.       END SUB
  2356. ' $SUBTITLE: 'COMMINFO - subroutine for variable of users baud/parity'
  2357. ' $PAGE
  2358. '
  2359. '  SUBROUTINE NAME    -- COMMINFO
  2360. '
  2361. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2362. '                              BPS               BAUD RATE INDICATOR
  2363. '                            EIGHT.BIT           INDICATE FOR N/8/1
  2364. '
  2365. '  OUTPUT PARAMETERS  -- BAUD.PARITY$
  2366. '
  2367. '  SUBROUTINE PURPOSE -- CREATE A STRING THAT SHOWS A USERS BAUD RATE AND
  2368. '                        PARITY.
  2369. '
  2370.       SUB COMMINFO STATIC
  2371. '
  2372. ' *****************************************************************************
  2373. ' *  DETERMINE BAUD AND PARITY                                                *
  2374. ' *****************************************************************************
  2375. '
  2376.   IF RELIABLE.MODE THEN _
  2377.      RELIABLE.MODE$ = "-R," _
  2378.   ELSE RELIABLE.MODE$ = ","
  2379.   BAUD.PARITY$ = MID$("    300 4501200240048009600",(-4*BPS),4) + _
  2380.                  " BAUD" + _
  2381.                  RELIABLE.MODE$ + _
  2382.                  MID$("N,8,1E,7,1",6 + 5*EIGHT.BIT,5)
  2383.   END SUB
  2384. ' $SUBTITLE: 'DELAYIT - subroutine to wait number of seconds specified'
  2385. ' $PAGE
  2386. '
  2387. '  SUBROUTINE NAME    -- DELAYIT
  2388. '
  2389. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2390. '                             DELAY.TIME           NUMBER OF SECONDS TO DELAY
  2391. '                                                  (0 TO 3,600)
  2392. '
  2393. '  OUTPUT PARAMETERS  -- NONE
  2394. '
  2395. '  SUBROUTINE PURPOSE -- TO WAIT THE NUMBER OF SECONDS INDICATED BEFORE
  2396. '                        RETURNING CONTROL TO THE CALLING ROUTINE.
  2397. '
  2398.       SUB DELAYIT (DELAY.TIME) STATIC
  2399.       IF DELAY.TIME < 1 THEN _
  2400.          EXIT SUB
  2401.       CALL FINDTIME (DELAY!)
  2402.       DELAY! = DELAY.TIME + DELAY!
  2403.       IF DELAY! < 86400! THEN _
  2404.          GOTO 50520
  2405. 50500 CALL FINDTIME (TI!)
  2406.       IF TI! > DELAY.TIME THEN _  ' IF SECONDS TO DELAY IS PAST
  2407.          GOTO 50500              ' MIDNIGHT WAIT FOR THE CLOCK TO WRAP AROUND
  2408.       DELAY! = DELAY! - 86400!   ' TO PAST MIDNIGHT AND ADJUST THE DELAY
  2409. 50520 CALL FINDTIME (TI!)
  2410.       IF TI! < DELAY! THEN _
  2411.          GOTO 50520
  2412.       END SUB
  2413. ' $SUBTITLE: 'MODEMPUT - subroutine to write modem commands to modem'
  2414. ' $PAGE
  2415. '
  2416. '  SUBROUTINE NAME    -- MODEMPUT
  2417. '
  2418. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  2419. '                        STRNG$                    MODEM COMMAND
  2420. '                        COMMANDS.BETWEEN.RINGS    INDICATOR TO WAIT FOR
  2421. '                                                  MODEM TO STOP RINGING
  2422. '                                                  BEFORE ISSUING COMMANDS
  2423. '                        DUMB.MODEM                INDICATOR THAT MODEM WOULD
  2424. '                                                  NOT UNDERSTAND COMMANDS
  2425. '
  2426. '  OUTPUT PARAMETERS  -- NONE
  2427. '
  2428. '  SUBROUTINE PURPOSE -- TO ISSUE MODEM COMMANDS TO THE MODEM
  2429. '
  2430.       SUB MODEMPUT (STRNG$) STATIC
  2431. '
  2432. ' *****************************************************************************
  2433. ' *  SEND MODEM COMMAND                                                       *
  2434. ' *****************************************************************************
  2435. '
  2436. 52070 IF DUMB.MODEM THEN _
  2437.          EXIT SUB
  2438.       IF NOT COMMANDS.BETWEEN.RINGS OR _
  2439.      NOT (INP(MODEM.STATUS.REGISTER) AND &H40) THEN _
  2440.      GOTO 52080
  2441.       CALL FINDTIME (CONNECT.DELAY!)
  2442.       CONNECT.DELAY! = CONNECT.DELAY! + 7
  2443. 52072 IF (INP(MODEM.STATUS.REGISTER) AND &H40) > 0 THEN _
  2444.      CALL FINDTIME (TI!) : _
  2445.      IF TI! > CONNECT.DELAY! OR _
  2446.         (ABS(CONNECT.DELAY! - TI!) > 30 AND _
  2447.          (TI! + 86400 > CONNECT.DELAY!)) THEN _
  2448.         GOTO 52080
  2449.       GOTO 52072
  2450. 52080 CALL DELAYIT (MODEM.COMMAND.DELAY.TIME)
  2451.       PRINT #3,STRNG$
  2452.       END SUB
  2453. ' $SUBTITLE: 'FINDFUNC - subroutine to find if function key was pressed'
  2454. ' $PAGE
  2455. '
  2456. '  SUBROUTINE NAME    -- FINDFUNC
  2457. '
  2458. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2459. '                        F1.KEY           FUNCTION KEY ONE VALUE
  2460. '                        F10.KEY          FUNCTION KEY TEN VALUE
  2461. '
  2462. '  OUTPUT PARAMETERS  -- FUNCTION.KEY (VALUE 1 TO 10 CORRESPONDING TO
  2463. '                                      THE FUNCTION KEY THAT WAS PRESSED).
  2464. '                        KEY.PRESSED$ (CHARACTER STRING INPUTTED).
  2465. '
  2466. '  SUBROUTINE PURPOSE -- TO DETERMINE IF A FUNCTION HAS BEEN PRESSED ON
  2467. '                        THE PC'S KEYBOARD THAT IS RUNNING RBBS-PC.
  2468. '
  2469.       SUB FINDFUNC STATIC
  2470. '
  2471. ' *****************************************************************************
  2472. ' *  TEST FOR FUNCTION KEY PRESSED                                            *
  2473. ' *****************************************************************************
  2474. '
  2475. 58040 KEY.PRESSED$ = INKEY$
  2476.       FUNCTION.KEY = 0
  2477.       IF LEN(KEY.PRESSED$) <> 2 THEN _
  2478.          EXIT SUB
  2479.       KEY.PRESSED = ASC(RIGHT$(KEY.PRESSED$,1))
  2480.       IF LOCAL.USER.MODE THEN _
  2481.          KEY.PRESSED$ = "" : _
  2482.          EXIT SUB
  2483.       IF KEY.PRESSED >= F1.KEY AND _
  2484.          KEY.PRESSED <= F10.KEY THEN _
  2485.              FUNCTION.KEY = KEY.PRESSED - 58:_
  2486.              EXIT SUB
  2487.       IF KEY.PRESSED = 79 THEN _     'End
  2488.          FUNCTION.KEY = 11 : _
  2489.          EXIT SUB
  2490.       IF KEY.PRESSED = 72 THEN _     'up arrow
  2491.          CALL CARRIER : _
  2492.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2493.             EXIT SUB _
  2494.          ELSE ADJUSTED.SECURITY = TRUE : _
  2495.               USER.SECURITY.LEVEL = USER.SECURITY.LEVEL + 1: _
  2496.               SUBROUTINE.PARAMETER = 2: _
  2497.               CALL LINE25: _
  2498.               CALL CALLOPT : _
  2499.               EXIT SUB
  2500.       IF KEY.PRESSED = 73 THEN _     'PgUp
  2501.          FUNCTION.KEY = 12 : _
  2502.          EXIT SUB
  2503.       IF KEY.PRESSED = 80 THEN _     'Down arrow
  2504.          CALL CARRIER : _
  2505.          IF SUBROUTINE.PARAMETER = -1 THEN _
  2506.             EXIT SUB_
  2507.          ELSE ADJUSTED.SECURITY = TRUE:_
  2508.               USER.SECURITY.LEVEL = USER.SECURITY.LEVEL - 1: _
  2509.               SUBROUTINE.PARAMETER = 2: _
  2510.               CALL LINE25: _
  2511.               CALL CALLOPT : _
  2512.               EXIT SUB
  2513.       END SUB
  2514. ' $SUBTITLE: 'FINDTIME - subroutine to calculate seconds since midnight'
  2515. ' $PAGE
  2516. '
  2517. '  SUBROUTINE NAME    -- FINDTIME
  2518. '
  2519. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2520. '                            SECONDS!          VARIABLE TO RETURN RESULTS WITH
  2521. '
  2522. '  OUTPUT PARAMETERS  --     SECONDS!          SECONDS SINCE MIDNIGHT
  2523. '
  2524. '  SUBROUTINE PURPOSE -- TO CALCULATE THE NUMBER OF SECONDS THAT HAVE
  2525. '                        ELASPED SINCE MIDNIGHT
  2526. '
  2527.       SUB FINDTIME (SECONDS!) STATIC
  2528. 58050 SECONDS! = TIMER
  2529.       END SUB
  2530. ' $SUBTITLE: 'ALLCAPS - subroutine to convert string to upper case'
  2531. ' $PAGE
  2532. '
  2533. '  SUBROUTINE NAME    -- ALLCAPS
  2534. '
  2535. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2536. '                            CONVERT.FIELD$    STRING TO MAKE UPPER CASE
  2537. '
  2538. '  OUTPUT PARAMETERS  --     CONVERT.FIELD$    CONVERTED STRINGS
  2539. '
  2540. '  SUBROUTINE PURPOSE -- SUBROUTINE TO CONVERT A STRING TO UPPER CASE
  2541. '
  2542.       SUB ALLCAPS (CONVERT.FIELD$) STATIC
  2543. 58060 IF TURBO.RBBS THEN _
  2544.          CALL RBBSULC (CONVERT.FIELD$) : _
  2545.          EXIT SUB
  2546.       FOR Z = 1 TO LEN(CONVERT.FIELD$)
  2547.           IF MID$(CONVERT.FIELD$,Z,1) > "@" THEN _
  2548.              MID$(CONVERT.FIELD$,Z,1) = CHR$(ASC(MID$(CONVERT.FIELD$,Z,1)) AND 223)
  2549.       NEXT
  2550.       END SUB
  2551. ' $SUBTITLE: 'ALLCAPSD - subroutine to convert string to upper case'
  2552. ' $PAGE
  2553. '
  2554. '  SUBROUTINE NAME    -- ALLCAPSD
  2555. '
  2556. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2557. '                            CONVERT.FIELD$    DIMENSIONED STRING TO MAKE
  2558. '                                              UPPER CASE
  2559. '
  2560. '  OUTPUT PARAMETERS  --     CONVERT.FIELD$    CONVERTED STRINGS
  2561. '
  2562. '  SUBROUTINE PURPOSE -- SUBROUTINE TO CONVERT A STRING TO UPPER CASE
  2563. '
  2564.       SUB ALLCAPSD (CONVERT.FIELD$(1),CONVERT.INDEX) STATIC
  2565. 58065 IF TURBO.RBBS THEN _
  2566.          CALL RBBSULC (CONVERT.FIELD$(CONVERT.INDEX)) : _
  2567.          EXIT SUB
  2568.       FOR Z = 1 TO LEN(CONVERT.FIELD$(CONVERT.INDEX))
  2569.           IF MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1) > "@" THEN _
  2570.              MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1) = CHR$(ASC(MID$(CONVERT.FIELD$(CONVERT.INDEX),Z,1)) AND 223)
  2571.       NEXT
  2572.       END SUB
  2573. ' $SUBTITLE: 'CHECKTIM - subroutine to see if time has elasped'
  2574. ' $PAGE
  2575. '
  2576. '  SUBROUTINE NAME    -- CHECKTIM
  2577. '
  2578. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2579. '                            MAX.TIME!         NUMBER OF SECONDS PAST MIDNIGHT
  2580. '                                              NOT TO EXCEED
  2581. '
  2582. '  OUTPUT PARAMETERS  -- SUBROUTINE.PARAMETER = 1 CURRENT TIME IS LESS THAN
  2583. '                                                 MAX.TIME!
  2584. '                        SUBROUTINE.PARAMETER = 2 CURRENT TIME IS GREATER THAN
  2585. '                                                 OR EQUAL TO MAX.TIME!
  2586. '
  2587. '  SUBROUTINE PURPOSE -- SUBROUTINE TO CHECK IF THE CURRENT TIME IS GREATER
  2588. '                        THAN OR EQUAL TO THE TIME ALLOWED
  2589. '
  2590.       SUB CHECKTIM (MAX.TIME!) STATIC
  2591. 58070 SUBROUTINE.PARAMETER = 1
  2592.       CALL FINDTIME (TI!)
  2593.       IF MAX.TIME! < 86400 AND TI! < MAX.TIME! THEN _
  2594.          EXIT SUB
  2595.       IF MAX.TIME! < 86400 AND TI! => MAX.TIME! THEN _
  2596.          SUBROUTINE.PARAMETER = 2 : _
  2597.          EXIT SUB
  2598.       TEST.TIME! = MAX.TIME! - 86400
  2599.       IF TEST.TIME! - TI! <= 0 THEN _
  2600.          EXIT SUB
  2601.       IF TI! => TEST.TIME! THEN _
  2602.          SUBROUTINE.PARAMETER = 2
  2603.       END SUB
  2604. ' $SUBTITLE: 'HASHRBBS - subroutine to determine where to look for user'
  2605. ' $PAGE
  2606. '
  2607. '  SUBROUTINE NAME    -- HASHRBBS
  2608. '
  2609. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2610. '                            STRNG.TO.HASH$    USER NAME TO LOCATE
  2611. '                            MAX.POSITION      MAXIMUM # USERS
  2612. '
  2613. '  OUTPUT PARAMETERS  --     PRIME.HASH        WHERE TO LOOK FIRST
  2614. '                            SECOND.HASH       LOOK THIS FAR AHEAD
  2615. '
  2616. '  SUBROUTINE PURPOSE -- WHERE TO LOOK FOR A USER IN USERS FILE
  2617. '                        LOOK FIRST AT PRIME POSITION, THEN ADD
  2618. '                        SECOND.HASH UNTIL FIND OR FIND UNUSED RECORD
  2619. '
  2620.       SUB HASHRBBS (STRNG.TO.HASH$,MAX.POSITION,PRIME.HASH,SECOND.HASH) STATIC
  2621. 58080 SECOND.HASH = (ASC(MID$(STRNG.TO.HASH$,2,1))*10  + 7) MOD _
  2622.            MAX.POSITION
  2623.       PRIME.HASH = _
  2624.            ((ASC(STRNG.TO.HASH$)*100  + _
  2625.              ASC(MID$(STRNG.TO.HASH$,LEN(STRNG.TO.HASH$) / 2,1)) * _
  2626.              10  + _
  2627.              ASC(RIGHT$(STRNG.TO.HASH$,1))) _
  2628.              MOD MAX.POSITION) + 1
  2629.       END SUB
  2630. ' $SUBTITLE: 'CALLOPT - subroutine to set prompts based on user security'
  2631. ' $PAGE
  2632. '
  2633. '  SUBROUTINE NAME    -- CALLOPT
  2634. '
  2635. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2636. '                            BEG.MAIN          POSITION START OF MAIN CMDS
  2637. '                            BEG.FILE          POSITION START OF FILE CMDS
  2638. '                            BEG.UTIL          POSITION START OF UTIL CMDS
  2639. '
  2640. '  OUTPUT PARAMETERS  -- PRESENT.OPTS$         DISPLAY WHAT USER CAN DO (1st)
  2641. '                        CALLERS.OPTS$         DISPLAY WHAT USER CAN DO (2nd)
  2642. '                        MAIN.OPTS$            MAIN OPTS USER CAN DO
  2643. '                        FILE.OPTS$            FILE OPTS USER CAN DO
  2644. '                        UTIL.OPTS$            UTIL OPTS USER CAN DO
  2645. '
  2646. '  SUBROUTINE PURPOSE -- SETS COMMAND LINE DISPLAY OF WHAT USER CAN DO BY
  2647. '                        SECTION AND DISPLAY OF WHAT ALL USER CAN DO
  2648. '
  2649.       SUB CALLOPT STATIC
  2650. 58090 FIRST = BEG.MAIN
  2651.       LAST = BEG.FILE - 1
  2652.       CALL SETOPTS (MAIN.OPTS$,FIRST,LAST)
  2653.       FIRST = BEG.FILE
  2654.       LAST = BEG.UTIL - 1
  2655.       CALL SETOPTS (FILE.OPTS$,FIRST,LAST)
  2656.       FIRST = BEG.UTIL
  2657.       LAST = BEG.UTIL + 10
  2658.       CALL SETOPTS (UTIL.OPTS$,FIRST,LAST)
  2659.       FIRST = 40
  2660.       LAST = 46
  2661.       CALL SETOPTS (SYS.OPTS$,FIRST,LAST)
  2662.       FIRST = 36
  2663.       LAST = 39
  2664.       CALL SETOPTS (GLOBAL.OPTS$,FIRST,LAST)
  2665.       PRESENT.OPTS$ = "Your valid commands are:"
  2666.       IF LEN(GLOBAL.OPTS$) > 0 THEN _
  2667.           PRESENT.OPTS$ = PRESENT.OPTS$ + " Globals: " + GLOBAL.OPTS$
  2668.       CALLERS.OPTS$ = "Main: " + MAIN.OPTS$ + _
  2669.                       " File: " + FILE.OPTS$ + _
  2670.                       " Util: " + UTIL.OPTS$
  2671.       IF LEN(SYS.OPTS$)>0 THEN _
  2672.          CALLERS.OPTS$ = CALLERS.OPTS$ + " Sysop: " + SYS.OPTS$
  2673.       MAIN.OPTS$ = GLOBAL.OPTS$ + MAIN.OPTS$
  2674.       FILE.OPTS$ = GLOBAL.OPTS$ + FILE.OPTS$
  2675.       UTIL.OPTS$ = GLOBAL.OPTS$ + UTIL.OPTS$
  2676.       CALL SRTSTRNG (SYS.OPTS$)
  2677.       CALL SRTSTRNG (MAIN.OPTS$)
  2678.       MAIN.OPTS$ = MAIN.OPTS$ + SYS.OPTS$
  2679.       CALL SRTSTRNG (FILE.OPTS$)
  2680.       CALL SRTSTRNG (UTIL.OPTS$)
  2681.       CALL INSCOMMA (MAIN.OPTS$)
  2682.       CALL INSCOMMA (FILE.OPTS$)
  2683.       CALL INSCOMMA (UTIL.OPTS$)
  2684.       DIR.PROMPT$ = "What directories (" + _
  2685.                     MID$("<U>pload,<A>ll,[ENTER] ", _
  2686.                     9*(USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW)+10)
  2687.       END SUB
  2688. ' $SUBTITLE: 'SETOPTS - subroutine to set prompts based on user security'
  2689. ' $PAGE
  2690. '
  2691. '  SUBROUTINE NAME    -- SETOPTS
  2692. '
  2693. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2694. '                            FIRST             POSITION WHERE START LOOKING
  2695. '                            LAST              POSITION WHERE QUIT LOOKING
  2696. '                            USER.SECURITY.LEVEL SECURITY OF USER
  2697. '
  2698. '  OUTPUT PARAMETERS  -- OPTIONS$              LIST OF COMMANDS USER CAN DO
  2699. '
  2700. '  SUBROUTINE PURPOSE -- STRING TOGETHER WHAT COMMANDS USER CAN DO
  2701. '                        IN A SECTION
  2702. '
  2703.       SUB SETOPTS (OPTIONS$,FIRST,LAST) STATIC
  2704. 58100 OPTIONS$ = ""
  2705.       FOR I = FIRST TO LAST
  2706.          IF USER.SECURITY.LEVEL >= OPT.SEC(I) THEN _
  2707.             IF MID$(ALL.OPTS$,I,1) <> " " THEN _
  2708.                OPTIONS$ = OPTIONS$ + MID$(ALL.OPTS$,I,1)
  2709.       NEXT
  2710.       CALL SRTSTRNG (OPTIONS$)
  2711.       END SUB
  2712. ' $SUBTITLE: 'CHKNEWBUL - subroutine to check whether got new bulletins'
  2713. ' $PAGE
  2714. '
  2715. '  SUBROUTINE NAME    -- CHKNEWBUL
  2716. '
  2717. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2718. '                            LAST.ON$          Last date of logon
  2719. '                                                format mm/dd/yy
  2720. '                            ACTIVE.BULLETINS  # of bulletins
  2721. '                            BULLETIN.PREFIX$  Filespec for bulletins
  2722. '
  2723. '  OUTPUT PARAMETERS  --     NUM.NEW.BULLETS   Number of new bulletins
  2724. '                            NEW.BULLETS$      List of new bullet #'s
  2725. '                            Q                 where last bulletin stored
  2726. '                                                 in B$()
  2727. '                            B$()              Bulletins #'s that are new
  2728. '                                                 (2,3,4,...)
  2729. '  SUBROUTINE PURPOSE -- Checks how many bulletins have system date
  2730. '                        at or later than date caller last logged on
  2731. '
  2732.       SUB CHKNEWBUL (LAST.ON$,NUM.NEW.BULLETS,NEW.BULLETS$) STATIC
  2733. 58110 NUM.NEW.BULLETS = 0
  2734.       NEW.BULLETS$ = ":  "
  2735.       BASE.DATE# = VAL(MID$(LAST.ON$,4,2)) + (100 * VAL(MID$(LAST.ON$,1,2))) + _
  2736.                    (10000# * (1900 + VAL(MID$(LAST.ON$,7,2))))
  2737.       FOR I = 1 TO ACTIVE.BULLETINS
  2738.          Y$ = MID$(STR$(I),2)
  2739.          X$ = BULLETIN.PREFIX$ + Y$ + CHR$(0)
  2740.      CALL RBBSFIND (X$,IX,YY,MM,DD)
  2741.      IF IX = 0 THEN _
  2742.             FDATE# = DD + (100 * MM) + (10000# * (YY+1980)) : _
  2743.             IF BASE.DATE# <= FDATE# THEN _
  2744.                NUM.NEW.BULLETS = NUM.NEW.BULLETS + 1 : _
  2745.                B$(NUM.NEW.BULLETS+1) = Y$ : _
  2746.                NEW.BULLETS$ = NEW.BULLETS$ + " " + Y$
  2747.       NEXT
  2748.       Q = NUM.NEW.BULLETS+1
  2749.       IF NUM.NEW.BULLETS < 1 THEN _
  2750.          NEW.BULLETS$ = ""
  2751.       END SUB
  2752. ' $SUBTITLE: 'SRTSTRNG - subroutine to sort characters in a string'
  2753. ' $PAGE
  2754. '
  2755. '  SUBROUTINE NAME    -- SRTSTRNG
  2756. '
  2757. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2758. '                              STRNG$           String to sort
  2759. '
  2760. '  OUTPUT PARAMETERS  --     STRNG$             Sorted string
  2761. '
  2762. '  SUBROUTINE PURPOSE -- Sorts characters in passed string.
  2763. '
  2764.       SUB SRTSTRNG (STRNG$) STATIC
  2765. 58120 S0 = LEN(STRNG$)
  2766.       S1 = S0
  2767.       X$ = "!"
  2768. 58122 S1 = S1\2
  2769.       IF S1 = 0 THEN _
  2770.          EXIT SUB
  2771.       S2 = S0 - S1
  2772.       FOR S3 = 1 TO S2
  2773.          S4 = S3
  2774. 58124    S5 = S4 + S1
  2775.          IF MID$(STRNG$,S4,1) > MID$(STRNG$,S5,1) THEN _
  2776.             LSET X$ = MID$(STRNG$,S4,1):_
  2777.             MID$(STRNG$,S4,1) = MID$(STRNG$,S5,1):_
  2778.             MID$(STRNG$,S5,1) = X$: _
  2779.             S4 = S4 - S1:_
  2780.             IF S4 > 0 THEN _
  2781.                GOTO 58124
  2782.       NEXT
  2783.       GOTO 58122
  2784.       END SUB
  2785. ' $SUBTITLE: 'INSCOMMA - subroutine to format commands in command prompt'
  2786. ' $PAGE
  2787. '
  2788. '  SUBROUTINE NAME    -- INSCOMMA
  2789. '
  2790. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2791. '                              STRNG$           String to replace
  2792. '
  2793. '  OUTPUT PARAMETERS  --     STRNG$             Replaced string
  2794. '
  2795. '  SUBROUTINE PURPOSE -- Inserts commands between each letter in STRNG$
  2796. '                        and encloses in pointed brackets
  2797.       SUB INSCOMMA (STRNG$) STATIC
  2798. 58130 L = LEN(STRNG$)
  2799.       IF L < 1 THEN _
  2800.          EXIT SUB
  2801.       LSET LINEMES$ = " <" + LEFT$(STRNG$,1)
  2802.       FOR K = 2 TO L
  2803.          MID$(LINEMES$,2*K,2) = "," + MID$(STRNG$,K,1)
  2804.       NEXT
  2805.       STRNG$ = LEFT$(LINEMES$,2*L+1) + ">"
  2806.       END SUB
  2807. ' $SUBTITLE: 'LOADNEW - subroutine to get latest uploads'
  2808. ' $PAGE
  2809. '
  2810. '  SUBROUTINE NAME    -- LOADNEW
  2811. '
  2812. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2813. '                          UPLOAD.DIRECTORY$  List of files uploaded
  2814. '
  2815. '  OUTPUT PARAMETERS  --     A$                Latest uploads
  2816. '
  2817. '  SUBROUTINE PURPOSE -- Loads table of most recent number of uploads
  2818. '                        by date
  2819.       SUB LOADNEW (ARA(2)) STATIC
  2820. 58140 IF FMS.DIRECTORY$ = "" THEN _
  2821.          EXIT SUB
  2822.       CALL OPENFMS (LAST.REC)
  2823.       FIELD 2, 23 AS PRE.DATE$,_
  2824.                 2 AS MM$,_
  2825.                 1 AS FILL1$,_
  2826.                 2 AS DD$,_
  2827.                 1 AS FILL2$,_
  2828.                 2 AS YY$,_
  2829.                 (2+MAX.DESC.LEN) AS FILL3$,_
  2830.                 3 AS CATEGORY$, _
  2831.                 2 AS FILL4$
  2832.       MAX.RECS = UBOUND(ARA,1)
  2833.       IF MAX.RECS < 1 THEN_
  2834.          MAX.RECS = 1 _
  2835.       ELSE IF MAX.RECS > 23 THEN _
  2836.               MAX.RECS = 23
  2837.       L = 0
  2838.       K = LAST.REC
  2839.       WHILE K > 0 AND L < MAX.RECS
  2840.          GET #2,K
  2841.          IF (CAN.DOWNLOAD.FROM.UP OR CATEGORY$ <> DEFAULT.CATEGORY.CODE$) THEN _
  2842.             L = L+1:_
  2843.             ARA(L,1) = 366*(VAL(YY$)-80)+31*VAL(MM$)+VAL(DD$)
  2844.          IF NOT CAN.DOWNLOAD.FROM.UP THEN _
  2845.             X = MIN.SEC.TO.VIEW _
  2846.          ELSE IF CATEGORY$ = "***" THEN _
  2847.                  X = SYSOP.SECURITY.LEVEL _
  2848.               ELSE IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _
  2849.                       X = MIN.SEC.TO.VIEW _
  2850.                    ELSE_
  2851.                        X = OPT.SEC(18)
  2852.          ARA(L,2) = X
  2853.          K = K - 1
  2854.       WEND
  2855.       CLOSE 2
  2856.       END SUB
  2857. ' $SUBTITLE: 'CTNEWFILES - subroutine to count how many files new'
  2858. ' $PAGE
  2859. '
  2860. '  SUBROUTINE NAME    -- CTNEWFILES
  2861. '
  2862. '  INPUT PARAMETERS   --     PARAMETER           MEANING
  2863. '                             LAST.ON$          Date of last logon
  2864. '                             UPLDS$            Latest uploads
  2865. '
  2866. '  OUTPUT PARAMETERS  --    NUM.NEW.FILES       How many after last logon
  2867. '
  2868. '  SUBROUTINE PURPOSE -- CHECKS HOW MANY FILES IN UPLDS$ WERE UPLOADED ON OR
  2869. '                        AFTER DATE OF LAST LOGON THAT THE USER CAN DOWNLOAD
  2870. '
  2871.       SUB CTNEWFILES (LAST.ON$,UPLDS(2),NUM.USER.FILES) STATIC
  2872. 58150 BASE.DATE = 366*(VAL(MID$(LAST.ON$,7,2))-80) + _
  2873.                   31*(VAL(MID$(LAST.ON$,1,2))) + _
  2874.                   VAL(MID$(LAST.ON$,4,2))
  2875.       NUM.NEW.FILES = 1
  2876.       NUM.USER.FILES = 0
  2877.       WHILE (BASE.DATE <= UPLDS(NUM.NEW.FILES,1) AND _
  2878.                 UPLDS(NUM.NEW.FILES,1)>0 AND_
  2879.                 NUM.NEW.FILES < UBOUND(UPLDS,1))
  2880.         IF USER.SECURITY.LEVEL >= UPLDS(NUM.NEW.FILES,2) THEN _
  2881.            NUM.USER.FILES = NUM.USER.FILES + 1
  2882.         NUM.NEW.FILES = NUM.NEW.FILES + 1
  2883.       WEND
  2884.       END SUB
  2885. ' $SUBTITLE: 'CTLINES - subroutine to determine file categories '
  2886. ' $PAGE
  2887. '
  2888. '  SUBROUTINE NAME    -- CTLINES
  2889. '
  2890. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  2891. '                        DIR.CATEGORY.FILE$    NAME OF THE FILE THAT HAS THE
  2892. '                                              NUMBER OF CATEGORIES IN IT.
  2893. '
  2894. '  OUTPUT PARAMETERS  -- MAX.ENTRIES           NUMBER OF FILE CATEGORIES
  2895. '
  2896. '  SUBROUTINE PURPOSE -- SUBROUTINE TO COUNT THE NUMBER OF CATEGORIES THAT A
  2897. '                        FILE CAN BE CLASSIFIED INTO.
  2898. '
  2899.       SUB CTLINES (MAX.ENTRIES) STATIC
  2900. 58160 MAX.ENTRIES = 3
  2901.       CALL FINDIT (DIR.CATEGORY.FILE$)
  2902.       IF OK THEN _
  2903.          WHILE NOT EOF(2):_
  2904.            MAX.ENTRIES = MAX.ENTRIES + 1:_
  2905.            LINE INPUT #2,A$:_
  2906.          WEND
  2907.       CLOSE 2
  2908.       IF MAX.ENTRIES < 10 THEN _
  2909.          MAX.ENTRIES = 10
  2910.       END SUB
  2911. ' $SUBTITLE: 'INITFMS - subroutine to initialize file management system'
  2912. ' $PAGE
  2913. '
  2914. '  SUBROUTINE NAME    -- INITFMS
  2915. '
  2916. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  2917. '                        UPLOAD.DIRECTORY$
  2918. '
  2919. '  OUTPUT PARAMETERS  -- CATEGORY.NAME$(), elements 1,2, possibly more
  2920. '                        CATEGORY.CODE$(), elements 1,2, possibly more
  2921. '                        CATEGORY.DESC$(), elements 1,2, possibly more
  2922. '                        CATEGORY.INDEX count of # elements in upload
  2923. '                           management system
  2924. '
  2925. '  SUBROUTINE PURPOSE -- SUBROUTINE TO INITIALIZE THE RBBS-PC UPLOAD MANAGEMENT
  2926. '                        SYSTEM
  2927.       SUB INITFMS (CATEGORY.NAME$(1),CATEGORY.CODE$(1),_
  2928.                    CATEGORY.DESC$(1),CATEGORY.INDEX) STATIC
  2929.       BLNK$ = " "
  2930.       CATEGORY.INDEX = 0
  2931.       IF FMS.DIRECTORY$ <> "" THEN _
  2932.          CATEGORY.INDEX = CATEGORY.INDEX + 1:_
  2933.          CATN$ = CATEGORY.NAME$(CATEGORY.INDEX) : _
  2934.          CALL BRKFNAME (FMS.DIRECTORY$,DRVPATH$,CATN$,EXTENSION$,FALSE) : _
  2935.          CATEGORY.NAME$(CATEGORY.INDEX) = CATN$ : _
  2936.          CATEGORY.CODE$(CATEGORY.INDEX) = "":_
  2937.          CATEGORY.DESC$(CATEGORY.INDEX) = "All uploads"_
  2938.       ELSE_
  2939.          LIMIT.SEARCH.TO.FMS = FALSE:_
  2940.          EXIT SUB
  2941.       IF LIMIT.SEARCH.TO.FMS THEN _
  2942.          CATEGORY.INDEX = CATEGORY.INDEX + 1 : _
  2943.          CATEGORY.NAME$(CATEGORY.INDEX) = "ALL" : _
  2944.          CATEGORY.CODE$(CATEGORY.INDEX) = "" : _
  2945.          CATEGORY.DESC$(CATEGORY.INDEX) = "All files"
  2946.       CALL FINDIT (DIR.CATEGORY.FILE$)
  2947.       IF NOT OK THEN _
  2948.          EXIT SUB
  2949.       WHILE NOT EOF(2)
  2950.          CATEGORY.INDEX = CATEGORY.INDEX + 1
  2951.          INPUT #2, CATEGORY.NAME$(CATEGORY.INDEX),_
  2952.                    CATEGORY.CODE$(CATEGORY.INDEX),_
  2953.                    CATEGORY.DESC$(CATEGORY.INDEX)
  2954.          CATR$ = CATEGORY.CODE$(CATEGORY.INDEX)
  2955.          CALL REMOVE (CATR$,BLNK$)
  2956.          CATEGORY.CODE$(CATEGORY.INDEX) = CATR$
  2957.       WEND
  2958.       CLOSE 2
  2959.       END SUB
  2960. ' $SUBTITLE: 'DISUPDIR - subroutine to display upload direcotry'
  2961. ' $PAGE
  2962. '
  2963. '  SUBROUTINE NAME    -- DISUPDIR
  2964. '
  2965. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  2966. '                     PASSED.CATEGORIES$    FILE "CATEGORIES" TO BE INCLUDED IN
  2967. '                                           THE SEARCH.
  2968. '                        SEARCH.STRING$     STRING TO SEARCH ON WITHIN THE
  2969. '                                           FILE "CATEGORIES" SELECTED
  2970. '                        SEARCH.DATE$       DATE EQUAL TO OR GREATER THAN TO BE
  2971. '                                           SEARCHED FOR WITH THE "CATEGORIES"
  2972. '                                           AND THE STRING TO SEARCH.
  2973. '                        DOWNLOAD.FLAG      SET TO RECORD # OF LINE TO BEGIN
  2974. '                                           VIEWING - 0 IF AT END
  2975. '
  2976. '  OUTPUT PARAMETERS  -- DOWNLOAD.FLAG      WHENEVER DOWNLOAD REQUESTED, SETS
  2977. '                                           TO NEXT RECORD TO VIEW.  OTHERWISE
  2978. '                                           LEAVES AT ZERO
  2979. '
  2980. '  SUBROUTINE PURPOSE -- DISPLAY THE FILES THAT MEET THE CRITERIA SELECTED IN
  2981. '                        RBBS-PC UPLOAD MANAGEMENT SYSTEM ON THE USERS SCREEN.
  2982. '
  2983.       SUB DISUPDIR (PASSED.CATEGORIES$,SEARCH.STRING$,SEARCH.DATE$,_
  2984.                     DOWNLOAD.FLAG) STATIC
  2985. 58170 CALL ALLCAPS (SEARCH.STRING$)
  2986.       BLNK$ = " "
  2987.       STOP.INTERRUPTS = TRUE
  2988.       CATEGORIES$ = "," + PASSED.CATEGORIES$ + ","
  2989.       CAN.DOWNLOAD = (USER.SECURITY.LEVEL >= OPT.SEC(18))
  2990.       CALL OPENFMS (UPLOAD.INDEX)
  2991.       UPLOAD.INDEX = UPLOAD.INDEX + 1
  2992.       IF DOWNLOAD.FLAG > 0 THEN _
  2993.          UPLOAD.INDEX = DOWNLOAD.FLAG : _
  2994.          DOWNLOAD.FLAG = 0
  2995.       FIELD 2,(33+MAX.DESC.LEN) AS PART.TO.PRINT$,_
  2996.                3 AS CATEGORY$,_
  2997.                2 AS FILLER$
  2998.       MAX.PRINT = PAGE.LENGTH - 1
  2999.       BELOW.MIN.SEC = (USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW)
  3000.       NON.STOP = (PAGE.LENGTH < 1)
  3001.       CHECK.POINT = 0
  3002.       LINES.PRINTED = 0
  3003. 58171 UPLOAD.INDEX = UPLOAD.INDEX - 1
  3004.       IF UPLOAD.INDEX < 1 THEN _
  3005.          GOTO 58177
  3006.       GET #2,UPLOAD.INDEX
  3007. 58172 CHECK.POINT = CHECK.POINT + 1
  3008.       IF CATEGORY$ = "***" THEN _
  3009.          IF NOT SYSOP THEN _
  3010.             GOTO 58176
  3011.       IF CATEGORY$ = DEFAULT.CATEGORY.CODE$ THEN _
  3012.          IF BELOW.MIN.SEC THEN _
  3013.             GOTO 58176
  3014. 58173 IF LEN(CATEGORIES$) > 2 THEN _
  3015.          KEE$ = "," + CATEGORY$ + "," :_
  3016.          CALL REMOVE (KEE$,BLNK$):_
  3017.          IF INSTR(CATEGORIES$,KEE$)=0 THEN _
  3018.             GOTO 58176
  3019.       IF SEARCH.STRING$ <> "" THEN _
  3020.          A$ = PART.TO.PRINT$ : _
  3021.          CALL ALLCAPS (A$) : _
  3022.          IF INSTR (A$,SEARCH.STRING$) = 0 THEN _
  3023.             GOTO 58176
  3024. 58174 IF SEARCH.DATE$ <> "" THEN _
  3025.          KEE$ = MID$(PART.TO.PRINT$,30,2) + _
  3026.                 MID$(PART.TO.PRINT$,24,2) + _
  3027.                 MID$(PART.TO.PRINT$,27,2) : _
  3028.          IF KEE$ < SEARCH.DATE$ THEN _
  3029.             GOTO 58177
  3030. '
  3031. ' *****************************************************************************
  3032. ' * Allow the FMS to be both fast and interruptable if a local                *
  3033. ' * user or there is nothing in the input buffer by using QTPUT.              *
  3034. ' *****************************************************************************
  3035. '
  3036. 58175 IF LOCAL.USER THEN _
  3037.          CALL QTPUT(PART.TO.PRINT$,1) _
  3038.       ELSE _
  3039.          IF EOF(3) THEN _
  3040.             CALL QTPUT(PART.TO.PRINT$,1) : _
  3041.          ELSE _
  3042.             A$ = PART.TO.PRINT$ : _
  3043.             SUBROUTINE.PARAMETER = 1 : _
  3044.             CALL TPUT : _
  3045.             IF RET THEN _
  3046.                GOTO 58177
  3047. 58176 IF LINES.PRINTED <= MAX.PRINT AND CHECK.POINT < 1000 THEN _
  3048.          GOTO 58171
  3049.       CALL CARRIER
  3050.       IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER=-1 THEN _
  3051.          GOTO 58177
  3052.       CALL TIMEREMAIN (TIME.REMAINING!)
  3053.       IF TIME.REMAINING! < 0.1 THEN _
  3054.          SUBROUTINE.PARAMETER = -1 : _
  3055.          GOTO 58177
  3056.       IF NON.STOP THEN _
  3057.          GOTO 58171
  3058.       IF LINES.PRINTED <= MAX.PRINT THEN _
  3059.          CALL QTPUT ("Files checked thru "+MID$(PART.TO.PRINT$,24,8),1)
  3060.       A$ = "MORE: [Y],N,NS" + _
  3061.            LEFT$(", or file(s) to download",-24*CAN.DOWNLOAD)
  3062.       SUBROUTINE.PARAMETER = 1
  3063.       NO.ADVANCE = TRUE
  3064.       CALL TGET
  3065.       IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = -1 THEN _
  3066.          GOTO 58177
  3067.       IF NO THEN_
  3068.          CALL WIPELINE (42) : _
  3069.          GOTO 58177
  3070.       IF LEN(B$(1))>2 THEN _
  3071.          IF NOT YES AND CAN.DOWNLOAD THEN _
  3072.             CALL SKIPLINE (1) : _
  3073.             DOWNLOAD.FLAG = UPLOAD.INDEX : _
  3074.             EXIT SUB
  3075.       CALL WIPELINE (42)
  3076.       IF NON.STOP THEN IF UPLOAD.INDEX > 999 THEN _
  3077.          IF (SEARCH.DATE$="" OR NOT EXPERT.USER) THEN_
  3078.             A$ = STR$(UPLOAD.INDEX) + _
  3079.                " files left to search.  Really go non-stop? (Y/[N])":_
  3080.             NO.ADVANCE = TRUE : _
  3081.            CALL TGET :_
  3082.            CALL WIPELINE (79) : _
  3083.            IF NOT YES THEN _
  3084.               NON.STOP = FALSE
  3085.       CHECK.POINT = 0
  3086.       GOTO 58171
  3087. 58177 CLOSE 2
  3088.       NON.STOP = (PAGE.LENGTH < 1)
  3089.       STOP.INTERRUPTS = FALSE
  3090.       A$ = ""
  3091.       END SUB
  3092. ' $SUBTITLE: 'CHKNARY - subroutine to check for a string in an array'
  3093. ' $PAGE
  3094. '
  3095. '  SUBROUTINE NAME    -- CHKNARY
  3096. '
  3097. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  3098. '                        ELEMENT$                THE STRING TO CHECK FOR
  3099. '                        ARRAY$()                THE ARRAY TO BE SEARCHED
  3100. '                        NUM.ENTRIES.TO.SEARCH   NUMBER OF ENTRIES WITHIN IN
  3101. '                                                THE ARRAY TO BE SEARCHED
  3102. '
  3103. '  OUTPUT PARAMETERS  -- IS.IN.ARA               0 = STRING NOT FOUND IN THE
  3104. '                                                    ARRAY SPECIFIED
  3105. '                                                OTHERWISE IT IS THE NUMBER OF
  3106. '                                                ELEMENT WITHIN THE ARRAY THAT
  3107. '                                                WAS FOUND TO MATCH
  3108. '
  3109. '  SUBROUTINE PURPOSE -- SEARCH AN ARRAY FOR A SPECIFIED STRING AND, IF FOUND,
  3110. '                        RETURN THE NUMBER OF THE ELEMENT THAT MATCHED.
  3111. '
  3112.       SUB CHKNARY (ELEMENT$,ARRAY$(1),NUM.ENTRIES.TO.SEARCH,IS.IN.ARA) STATIC
  3113. 58180 IS.IN.ARA = 1
  3114.       CALL ALLCAPS(ELEMENT$)
  3115.       MAX.TRIES = NUM.ENTRIES.TO.SEARCH + 1
  3116.       ARRAY$(MAX.TRIES) = ELEMENT$
  3117.       WHILE ARRAY$(IS.IN.ARA) <> ELEMENT$
  3118.          IS.IN.ARA = IS.IN.ARA + 1
  3119.       WEND
  3120.       IF IS.IN.ARA = MAX.TRIES THEN _
  3121.          IS.IN.ARA = 0
  3122.       END SUB
  3123. ' $SUBTITLE: 'FMS - subroutine to search the upload management system'
  3124. ' $PAGE
  3125. '
  3126. '  SUBROUTINE NAME    -- FMS
  3127. '
  3128. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  3129. '                        DIR.TO.SEARCH$          RBBS-PC "DIR" CATEGORY TO LOOK
  3130. '                                                FOR
  3131. '                        SEARCH.STRING$          STRING TO SEARCH FOR
  3132. '                        SEARCH.DATE$            DATE TO SEARCH FOR
  3133. '                        CATEGORY.NAME$()
  3134. '                        CATEGORY.CODE$()
  3135. '                        CATEGORY.DESC$()
  3136. '                        CAT.FOUND
  3137. '                        NUM.CATEGORIES
  3138. '
  3139. '  OUTPUT PARAMETERS  -- PROCESSED.IN.FMS
  3140. '                        DOWNLOAD.FLAG
  3141. '
  3142. '  SUBROUTINE PURPOSE -- TO SEARCH THE UPLOAD MANAGMENT SYSTEM AND DISPLAY THE
  3143. '                        FILES BEING SEARCHED FOR AS WELL AS THE CATEGORY DE-
  3144. '                        SCRIPTIONS
  3145. '
  3146.       SUB FMS (DIR.TO.SEARCH$,SEARCH.STRING$,SEARCH.DATE$,_
  3147.                PROCESSED.IN.FMS,CATEGORY.NAME$(1),CATEGORY.CODE$(1),_
  3148.                CATEGORY.DESC$(1),DOWNLOAD.FLAG,CAT.FOUND) STATIC
  3149. 58200 DOWNLOAD.FLAG = 0
  3150.       CALL CHKNARY (DIR.TO.SEARCH$,CATEGORY.NAME$(),NUM.CATEGORIES,CAT.FOUND)
  3151.       IF CAT.FOUND > 0 THEN _
  3152.          SUBROUTINE.PARAMETER = 5 : _
  3153.          GOSUB 58202 : _
  3154.          A$ = "Scanning directory " + DIR.TO.SEARCH$ + HDR$ + _
  3155.               " - " + CATEGORY.DESC$(CAT.FOUND) : _
  3156.          CALL TPUT : _
  3157.          CAT$ = CATEGORY.CODE$(CAT.FOUND) : _
  3158.          CALL DISUPDIR (CAT$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG)
  3159.       PROCESSED.IN.FMS = (CAT.FOUND > 0)
  3160.       EXIT SUB
  3161. 58202 A$ = SEARCH.DATE$
  3162.       IF LEN(A$) > 0 THEN _
  3163.          A$ = MID$(A$,3) + LEFT$(A$,2)
  3164.       HDR$ = " for " + SEARCH.STRING$ + A$
  3165.       IF LEN(HDR$) < 6 THEN _
  3166.          HDR$ = ""
  3167.       RETURN
  3168.       END SUB
  3169. ' $SUBTITLE: 'REMOVE - subroutine to delete a string from within a string'
  3170. ' $PAGE
  3171. '
  3172. '  SUBROUTINE NAME    -- REMOVE
  3173. '
  3174. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  3175. '                        BADSTRING$              STRING CONTAINING CHARACTERS
  3176. '                                                TO BE DELETED FROM "L$"
  3177. '                        L$                      STRING TO BE ALTERED
  3178. '
  3179. '  OUTPUT PARAMETERS  -- L$                      WITH THE CHARACTERS IN
  3180. '                                                "BADSTRING#" DELETED FROM IT
  3181. '
  3182. '  SUBROUTINE PURPOSE -- TO REMOVE ALL INSTANCES OF THE CHARACTERS IN
  3183. '                        "BADSTRING$" FROM "L$"
  3184. '
  3185.       SUB REMOVE (L$,BADSTRNG$) STATIC
  3186. 58210 J = 0
  3187.       FOR I=1 TO LEN(L$)
  3188.          IF INSTR(BADSTRNG$,MID$(L$,I,1)) = 0 THEN_
  3189.             J = J+1:_
  3190.             MID$(L$,J,1) = MID$(L$,I,1)
  3191.       NEXT I
  3192.       L$ = LEFT$(L$,J)
  3193.       END SUB
  3194. ' $SUBTITLE: 'BUFSTRNG - subroutine to write a string with imbedded CR/LF'
  3195. ' $PAGE
  3196. '
  3197. '  SUBROUTINE NAME    -- BUFSTRNG
  3198. '
  3199. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  3200. '                        STRNG$                  STRING TO BE WRITTEN OUT
  3201. '                        DATA.SIZE               LENGTH OF STRING - # LEFT
  3202. '                                                    CHARS TO OUTPUT
  3203. '
  3204. '  OUTPUT PARAMETERS  -- STRNG$                  IS WRITTEN TO THE USER
  3205. '
  3206. '  SUBROUTINE PURPOSE -- TO SEARCH THE STRING, STRNG$, FOR IMBEDDED CARRIAGE
  3207. '                        RETURNS AND LINE FEEDS AND WRITE OUT EACH LINE WITH
  3208. '                        THE APPROPRIATE SUBSTITUTION (CR/LF IF TO THE LOCAL
  3209. '                        SCREEN OR CR/NULLS/LF IF TO THE COMMUNICATIONS PORT).
  3210. '
  3211. 58300 SUB BUFSTRNG (STRNG$,DATA.SIZE) STATIC
  3212.       IF LEN(STRNG$) < 1 THEN _                                      ' CPC15-1B
  3213.          EXIT SUB                                                    ' CPC15-1B
  3214.       FF = PAGE.LENGTH - 1
  3215.       START.BYTE = 1 - (ASC(STRNG$)=10)
  3216.       IF LEN(STRNG$) < 1 THEN _
  3217.          EXIT SUB
  3218. 58301 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
  3219.       CR.FOUND = (CRAT > 0)
  3220.       EOL.LEN = -2 * CR.FOUND
  3221.       IF CR.FOUND THEN _
  3222.      EOD = CRAT _
  3223.       ELSE EOD = DATA.SIZE + 1
  3224.       NUM.BYTES = EOD - START.BYTE
  3225.       CALL QTPUT (MID$(STRNG$,START.BYTE,NUM.BYTES),-(CR.FOUND))
  3226.       IF RET THEN _
  3227.          GOTO 58309
  3228.       IF LINES.PRINTED < FF THEN _
  3229.          GOTO 58304
  3230.       CALL CARRIER
  3231.       IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = -1 THEN _
  3232.          GOTO 58309
  3233.       IF NON.STOP THEN _
  3234.          GOTO 58304
  3235.       IF STOP.INTERRUPTS THEN _
  3236.          A$ = "MORE: [Y],N,NS" _
  3237.       ELSE _
  3238.          A$ = "Press [ENTER] to continue"
  3239.       LINES.PRINTED = 0
  3240.       SUBROUTINE.PARAMETER = 1
  3241.       NO.ADVANCE = TRUE
  3242.       CALL TGET
  3243.       CALL WIPELINE (26)
  3244.       IF NO THEN _
  3245.          IF STOP.INTERRUPTS THEN _
  3246.             GOTO 58309
  3247. 58304 START.BYTE = EOD + EOL.LEN
  3248.       IF START.BYTE <= DATA.SIZE THEN _
  3249.          GOTO 58301
  3250.       EXIT SUB
  3251. 58309 'Common ABORT routine
  3252.       STOP.FILE = TRUE
  3253.       END SUB
  3254. ' $SUBTITLE: 'BUFFILE - subroutine to write a sequential file to the user'
  3255. ' $PAGE
  3256. '
  3257. '  SUBROUTINE NAME    -- BUFFILE
  3258. '
  3259. '  INPUT PARAMETERS   -- PARAMETER                      MEANING
  3260. '                        FILENAME$               NAME OF THE FILE TO WRITE TO
  3261. '                                                OUT TO THE USER
  3262. '
  3263. '  OUTPUT PARAMETERS  -- NONE                    FILE IS WRITTEN TO THE USER
  3264. '
  3265. '  SUBROUTINE PURPOSE -- TO DISPLAY A SEQUENTIAL FILE TO THE USER
  3266. '
  3267. 58400 SUB BUFFILE (FILNAME$) STATIC
  3268.       CALL FINDIT (FILNAME$)
  3269.       IF NOT OK THEN _
  3270.          EXIT SUB
  3271.       CALL OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC)
  3272.       DATA.SIZE = BUFFER.SIZE
  3273.       FIELD 2, DATA.SIZE AS SEQ.REC$
  3274.       NON.STOP = (PAGE.LENGTH < 1)
  3275.       STOP.FILE = FALSE
  3276.       IF STOP.INTERRUPTS THEN _
  3277.          A$ = "* <Ctrl K>/<Ctrl X> aborts <Ctrl S> suspends *" : _
  3278.          SUBROUTINE.PARAMETER = 2 : _
  3279.          CALL TPUT
  3280.       TU = 0
  3281. 58405 TU = TU + 1
  3282.       IF TU < NUM.RECS THEN_
  3283.          GET 2,TU _
  3284.       ELSE IF TU = NUM.RECS THEN _
  3285.               GET 2,TU : _
  3286.               X = INSTR(SEQ.REC$,CHR$(26)) :_
  3287.               IF X=0 OR X > LEN.LAST.REC THEN _
  3288.                  DATA.SIZE = LEN.LAST.REC _
  3289.               ELSE DATA.SIZE = X-1 _
  3290.            ELSE GOTO 58419
  3291.       IF (NOT STOP.INTERRUPTS) THEN _
  3292.          CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_
  3293.       ELSE IF LOCAL.USER THEN _
  3294.               CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_
  3295.       ELSE IF EOF(3) THEN _
  3296.               CALL BUFSTRNG (SEQ.REC$,DATA.SIZE)_
  3297.       ELSE _
  3298.           A$ = LEFT$(SEQ.REC$,DATA.SIZE) : _
  3299.           SUBROUTINE.PARAMETER = 4 : _
  3300.           CALL TPUT : _
  3301.           IF SUBROUTINE.PARAMETER = -1 OR RET THEN _
  3302.              GOTO 58419
  3303.       CALL TIMEREMAIN (TIME.REMAINING!)
  3304.       IF TIME.REMAINING! < 0.1 THEN _
  3305.          GOTO 58419
  3306.       IF NOT STOP.FILE THEN _
  3307.          GOTO 58405
  3308. 58419 CLOSE 2
  3309.       NON.STOP = (PAGE.LENGTH < 1)
  3310.       END SUB
  3311. ' $SUBTITLE: 'FINDLAST - subroutine to find last occurence of a string'
  3312. ' $PAGE
  3313. '
  3314. '  SUBROUTINE NAME    -- FINDLAST
  3315. '
  3316. '  INPUT PARAMETERS   -- PARAMETER             MEANING
  3317. '                        LOOK.IN$           STRING TO LOOK INTO
  3318. '                        LOOK.FOR$          STRING TO SEARCH FOR
  3319. '
  3320. '  OUTPUT PARAMETERS  -- WHERE.FOUND        POSITION IN LOOK.IN$ THAT
  3321. '                                            LOOK.FOR$ FOUND
  3322. '                        NUM.FINDS          HOW MANY OCCURENCES IN LOOK.IN$
  3323. '
  3324. '  SUBROUTINE PURPOSE -- Finds last occurence of LOOK.FOR$ in LOOK.IN$ and
  3325. '                        returns count of # of occurences.  If none found,
  3326. '                        both returned parms are 0.
  3327. '
  3328.       SUB FINDLAST (LOOK.IN$,LOOK.FOR$,WHERE.FOUND,NUM.FINDS) STATIC
  3329. 58600 WHERE.FOUND = INSTR(LOOK.IN$,LOOK.FOR$)
  3330.       NUM.FINDS = -(WHERE.FOUND > 0)
  3331.       NEXT.FOUND = INSTR(WHERE.FOUND+1,LOOK.IN$,LOOK.FOR$)
  3332.       WHILE NEXT.FOUND > 0
  3333.         NUM.FINDS = NUM.FINDS + 1
  3334.         WHERE.FOUND = NEXT.FOUND
  3335.         NEXT.FOUND = INSTR(WHERE.FOUND+1,LOOK.IN$,LOOK.FOR$)
  3336.       WEND
  3337.       END SUB
  3338. ' $SUBTITLE: 'ROTORSDIR - search thru a list of subdirs for a file'
  3339. ' $PAGE
  3340. '
  3341. '  SUBROUTINE NAME    -- ROTORSDIR
  3342. '
  3343. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3344. '                        FILNAME$                  FILE NAME TO LOOK FOR
  3345. '                        SDIR.ARA                  ARRAY OF SUBDIRECTORIES
  3346. '                        MAX.SEARCH                MAX # OF SUBDIRECTORIES
  3347. '
  3348. '   OUTPUT PARAMETERS -- FNAME$                    ADD SUBDIRECTORY TO THE
  3349. '                                                  FILE NAME IF FOUND.  OTHER-
  3350. '                                                  WISE DON'T.
  3351. '                        OK                        TRUE IF FILE WAS FOUND
  3352. '
  3353. '  SUBROUTINE PURPOSE -- HUNT THROUGH A LIST OF SUBDIRECTORIES TO DETERMINE
  3354. '                        IF A FILE IS IN ANY OF THEM.  IF FILE IS FOUND, OPEN
  3355. '                        THE FILE AS FILE #2, ADD THE DRIVE/PATH TO THE FILE
  3356. '                        NAME, AND SETS OK TO TRUE.  IF FILE ISN'T FOUND, SET
  3357. '                        FILE NAME TO THE LAST SUBDIRECTORY SEARCHED -- WHICH
  3358. '                        SHOULD BE THE UPLOAD SUBDIRECTORY.
  3359. '
  3360.       SUB ROTORSDIR (FILNAME$,SDIR.ARA$(1),MAX.SEARCH) STATIC
  3361. 58700 OK = FALSE
  3362.       NUM.SEARCH = 1
  3363.       WHILE (NOT OK) AND NUM.SEARCH <= MAX.SEARCH AND_
  3364.         SDIR.ARA$(NUM.SEARCH)<>""
  3365.           X$ = SDIR.ARA$(NUM.SEARCH) + FILNAME$
  3366.           CALL FINDIT (X$)
  3367.           NUM.SEARCH = NUM.SEARCH + 1
  3368.       WEND
  3369.       FILNAME$ = X$
  3370.       END SUB
  3371. ' $SUBTITLE: 'WIPELINE - Wipe away a line so next overprints'
  3372. ' $PAGE
  3373. '
  3374. '  SUBROUTINE NAME    -- WIPELINE
  3375. '
  3376. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3377. '                            CARRIAGE.RETURN$
  3378. '                            CHARS.TO.WIPE            # OF CHARACTERS TO BLANK
  3379. '                            NULLS
  3380. '
  3381. '   OUTPUT PARAMETERS -- NONE
  3382. '
  3383. '  SUBROUTINE PURPOSE -- WIPE AWAY A LINE AND LEAVE CURSOR AT BEGINNING OF THE
  3384. '                        SAME LINE SO THAT THE NEXT LINE WILL PRINT IN ITS
  3385. '                        PLACE
  3386. '
  3387.       SUB WIPELINE (CHARS.TO.WIPE) STATIC
  3388. 58800 IF NULLS THEN _
  3389.          CALL SKIPLINE (1) : _
  3390.          EXIT SUB
  3391.       IF NOT LOCAL.USER THEN _
  3392.          PRINT #3,CARRIAGE.RETURN$;SPACE$(CHARS.TO.WIPE);CARRIAGE.RETURN$
  3393.       IF SNOOP THEN _
  3394.          LOCATE ,1 :  _
  3395.          PRINT SPACE$(CHARS.TO.WIPE); : _
  3396.          LOCATE ,1
  3397.       END SUB
  3398. ' $SUBTITLE: 'GETDIRS -- Prompt for directories to search'
  3399. ' $PAGE
  3400. '
  3401. '  SUBROUTINE NAME    -- GETDIRS
  3402. '
  3403. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3404. '                             STRNG$                  OPTION TO ADD IN PROMPT
  3405. '                                                     TO EXPLAIN ENTER
  3406. '                             DIR.PROMPT$             BASE OF DIRECTORY PROMPT
  3407. '
  3408. '   OUTPUT PARAMETERS --     B$
  3409. '                            Q
  3410. '  SUBROUTINE PURPOSE -- Prompt for directories to search
  3411. '
  3412.       SUB GETDIRS (STRNG$) STATIC
  3413. 58900 A$ = DIR.PROMPT$ + STRNG$ + ")"
  3414.       SUBROUTINE.PARAMETER = 1
  3415.       CALL TGET
  3416.       IF Q = 0 OR SUBROUTINE.PARAMETER = -1 THEN _
  3417.          EXIT SUB
  3418.       IF INSTR("Hh",B$(1)) THEN _
  3419.          CALL BUFFILE (DIRECTORY.PATH$+DIRECTORY.EXTENTION$+_
  3420.                       "."+DIRECTORY.EXTENTION$):_
  3421.          GOTO 58900
  3422.       END SUB
  3423. '
  3424. ' $SUBTITLE: 'CONVDIRS -- Converts coded response to right directory'
  3425. ' $PAGE
  3426. '
  3427. '  SUBROUTINE NAME    -- CONVDIRS
  3428. '
  3429. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3430. '                            STRT               ELEMENT TO BEGIN WITH
  3431. '                            B$                 ARRAY TO CONVERT
  3432. '                            Q                  LAST ELEMENT TO CONFERT
  3433. '
  3434. '   OUTPUT PARAMETERS --     B$                 CONVERTED DIRECTORY LIST
  3435. '
  3436. '  SUBROUTINE PURPOSE -- LET THE USER PUT IN A SHORT STANDARD STRING FOR A
  3437. '                        DIRECTORY
  3438. '
  3439. '
  3440. 58950 SUB CONVDIRS (STRT) STATIC
  3441.       FOR I=STRT TO Q
  3442.           CALL ALLCAPSD(B$(),I)
  3443.           IF B$(I)="U" THEN _
  3444.              B$(I) = UPLOAD.DIR.CHECK$
  3445.           IF B$(I) = "A" THEN _
  3446.              B$(I) = "ALL"
  3447.           IF B$(I) = "ALL" THEN _
  3448.              IF MASTER.DIRECTORY.NAME$ <> "" THEN _
  3449.                 B$(I) = MASTER.DIRECTORY.NAME$ : _
  3450.                 IF USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW THEN _
  3451.                    Q = Q + 1 : _
  3452.                    B$(Q) = UPLOAD.DIR.CHECK$
  3453.       NEXT
  3454.       END SUB
  3455. ' $SUBTITLE: 'MUSIC - subroutine to PLAY MUSIC'
  3456. ' $PAGE
  3457. '
  3458. '  SUBROUTINE NAME    -- MUSIC
  3459. '
  3460. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  3461. '                                 1   PLAY CONSIDER YOURSELF(OPENING SCREEN)
  3462. '                                 2   PLAY WALK RIGHT IN(NEW USERS)
  3463. '                                 3   PLAY DRAGNET (SECURITY VIOLATION)
  3464. '                                 4   PLAY GOODBYE CHARLIE (GOODBYE)
  3465. '                                 5   PLAY TAPS (ACCESS DENIED)
  3466. '                                 6   PLAY OOM PAH PAH (DOWNLOAD)
  3467. '                                 7   PLAY THNKS FOR MEMORIES(UPLOAD)
  3468. '
  3469. '  OUTPUT PARAMETERS  -- NONE
  3470. '
  3471. '  SUBROUTINE PURPOSE -- PROVIDE SYSOP'S AND THE VISUALLY IMPARED WITH
  3472. '                        AUDITORY FEEDBACK ON WHAT RBBS-PC IS DOING
  3473. '
  3474.       SUB MUSIC (PASSED.ARG) STATIC
  3475. 59100 FF = PASSED.ARG
  3476.       SUBROUTINE.PARAMETER = 0
  3477.       IF (NOT MUSIC) OR LOCAL.USER.MODE THEN _
  3478.          EXIT SUB
  3479.       ON FF GOTO 59102,59104,59106,59108,59110,59112,59114
  3480.       EXIT SUB
  3481. 59102 '---[Introduction CONSIDER YOURSELF]---
  3482.     LEC$ = "MBT180A4B-8B-8B-8B-2.G4A8F2"
  3483.     PLAY "O2 X" + VARPTR$(LEC$)
  3484.     EXIT SUB
  3485. 59104 '---[New User WALK RIGHT IN]---
  3486.     LEC1$ = "MBT180G4G4D2G8F+8F8E2A8B8":LEC2$="C8C+8D8C8":LEC3$="B4G2"
  3487.     PLAY "O2 X"+VARPTR$(LEC1$)+"O3 X"+VARPTR$(LEC2$)+"O2 X"+VARPTR$(LEC3$)
  3488.     EXIT SUB
  3489. 59106 '---[Security Violation DRAGNET THEME]---
  3490.      LEC$ = "MBT120C2D8E-4C2.C2D8E-4C4G-2."
  3491.      PLAY "O2 X" + VARPTR$(LEC$)
  3492.      EXIT SUB
  3493. 59108 '---[Goodbye GOODBYE CHARLIE]---
  3494.       LEC$ = "MBT180B-2.G2.F4D2."
  3495.       PLAY "O2 X" + VARPTR$(LEC$)
  3496.       EXIT SUB
  3497. 59110 '---[Access Denied TAPS]---
  3498.       LEC1$ = "MBT90F8A16":LEC2$="C4.":LEC3$="A4F4C2.C8C16F2"
  3499.       PLAY "O2 X"+VARPTR$(LEC1$)+"O3 X"+VARPTR$(LEC2$)+"O2 X"+VARPTR$(LEC3$)
  3500.       EXIT SUB
  3501. 59112 '---[Download OOM PAH PAH]---
  3502.        LEC$ = "MBT180F4A4A4C4A4A4G4A4G4D2"
  3503.        PLAY "O2 X" + VARPTR$(LEC$)
  3504.        EXIT SUB
  3505. 59114 '---[Upload THANKS FOR THE MEMORIES]---
  3506.        LEC1$ = "MBT180C2." :LEC2$ = "A8G8F4D2"
  3507.        PLAY "O3 X" + VARPTR$(LEC1$)+ "O2 X" + VARPTR$(LEC2$)
  3508.        END SUB
  3509. ' $SUBTITLE: 'TWOBYTEDATE -- subroutine to put date in two bytes'
  3510. ' $PAGE
  3511. '
  3512. '  SUBROUTINE NAME    -- TWOBYTEDATE
  3513. '
  3514. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  3515. '                             YY       FOUR DIGIT YEAR (I.E. 1987)
  3516. '                             MM       MONTH
  3517. '                             DD       DAY
  3518. '                           RESULT$    LOCATION TO PLACE THE RESULT
  3519. '
  3520. '  OUTPUT PARAMETERS  -- RESULT$       TWO BYTE COMPRESSED DATE FOR USE IN
  3521. '                                      A RANDOM RECORD
  3522. '
  3523. '  SUBROUTINE PURPOSE -- COMPRESS AN 8-CHARACTER DATE INTO TWO CHARACTERS
  3524.       SUB TWOBYTEDATE (YY,MM,DD,RESULT$) STATIC
  3525. 59200 RESULT$ = CHR$(((YY-1980)*2) OR -((MM AND 8)<>0)) + _
  3526.                 CHR$((MM AND NOT 8)*32+DD)
  3527.       END SUB
  3528. ' $SUBTITLE: 'GETYMD -- subroutine to unpack a two-byte date'
  3529. ' $PAGE
  3530. '
  3531. '  SUBROUTINE NAME    -- GETYMD
  3532. '
  3533. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  3534. '                          TWOBYTE$    PACKED TWO-BYTE DATE FIELD
  3535. '                            YMD       1 = YEAR
  3536. '                                      2 = MONTH
  3537. '                                      3 = DAY
  3538. '                           RESULT     LOCATION TO PLACE THE RESULT
  3539. '
  3540. '  OUTPUT PARAMETERS  -- RESULT        FOUR DIGIT RESULT OF UNPAKING THE DATE
  3541. '
  3542. '  SUBROUTINE PURPOSE -- UNPACK A COMPRESSED TWO-BYTE DATE FIELD
  3543. '
  3544.       SUB GETYMD (TWOBYTE$,YMD,RESULT) STATIC
  3545.       ON YMD GOTO 59205,59210,59215
  3546.       EXIT SUB
  3547. 59205 RESULT = (ASC(TWOBYTE$)AND NOT 1)/2 + 1980
  3548.       EXIT SUB
  3549. 59210 RESULT = FIX((ASC(MID$(TWOBYTE$,2))/32))OR((ASC(TWOBYTE$)AND 1)*8)
  3550.       EXIT SUB
  3551. 59215 RESULT = ASC(MID$(TWOBYTE$,2))AND NOT 224
  3552.       END SUB
  3553. ' $SUBTITLE: 'COMPDATE -- subroutine to compute elased days'
  3554. ' $PAGE
  3555. '
  3556. '  SUBROUTINE NAME    -- COMPDATE
  3557. '
  3558. '  INPUT PARAMETERS   --   PARAMETER     MEANING
  3559. '                            YY        YEAR
  3560. '                            MM        MONTH
  3561. '                            DD        DAY
  3562. '                           RESULT!    LOCATION TO PLACE THE RESULT
  3563. '
  3564. '  OUTPUT PARAMETERS  -- RESULT!       COMPUTE COMPUTATIONAL DATE
  3565. '
  3566. '  SUBROUTINE PURPOSE -- COMPUTES A COMPUTATIONAL DATE FROM YEAR, MONTH, DAY.
  3567. '                        RESULTS MAY BE USED TO COMPUTE THE NUMBER OF ELASPED
  3568. '                        DAYS BETWEEN TWO DATES.  YOU MAY PASS A 2 OR 4 DIGIT
  3569. '                        YEAR, BUT FOR MEANINGFUL RESULTS, BE CONSISTENT
  3570. '
  3571.       SUB COMPDATE (YY,MM,DD,RESULT!) STATIC
  3572.       RESULT! = YY*365.0 + _
  3573.                 INT((YY-1)/4) + _
  3574.                 (MM-1)*28 + _
  3575.                 VAL(MID$("000303060811131619212426",(MM-1)*2+1,2)) - _
  3576.                 ((MM>2)AND((YY MOD 4)=0)) + _
  3577.                 DD
  3578.       END SUB
  3579. ' $SUBTITLE: 'PROTOCOL - check for external protocols'
  3580. ' $PAGE
  3581. '
  3582. '  SUBROUTINE NAME    -- PROTOCOL
  3583. '
  3584. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3585. '                        TRANSFER.OPTIONS$         FILE TRANSFER PROTOCOLS
  3586. '                                                  THAT ARE ALLOWED.
  3587. '
  3588. '   OUTPUT PARAMETERS -- PCKERMIT.EXE.FILE$        FILE TO TRANSFER CONTROL TO
  3589. '                                                  FOR KERMIT PROTOCOL
  3590. '                        KERMIT.SUPPORT            SWITCH INDICATING KERMIT IS
  3591. '                                                  AVAILABLE
  3592. '                        XFER.COM.FILE$            FILE TO TRANSFER CONTROL TO
  3593. '                                                  FOR YMODEM, IMODEM & YMODEMG
  3594. '                        XFER.SUPPORT              SWITCH INDICATING THAT
  3595. '                                                  YMODEM, IMODEM & YMODEMG
  3596. '                                                  ARE AVAILABLE
  3597. '                        WXMODEM.COM.FILE$         FILE TO TRANSFER CONTROL TO
  3598. '                                                  FOR WXMODEM SUPPORT
  3599. '                        WXMODEM.SUPPORT           SWITCH INDICATING THAT
  3600. '                                                  WXMODEM IS AVAILABLE
  3601. '
  3602. '  SUBROUTINE PURPOSE -- TO DETERMINE IF EXTERNAL PROTOCOL'S ARE AVAILABLE
  3603. '
  3604.       SUB PROTOCOL STATIC
  3605. 62600 XFER.SUPPORT = TRUE
  3606.       WXMODEM.SUPPORT = TRUE
  3607.       KERMIT.SUPPORT = TRUE
  3608.       WXMODEM.COM.FILE$ = PROTOCOL.PATH$ + "WXMODEM.COM"
  3609.       CALL FINDIT (WXMODEM.COM.FILE$)
  3610.       IF NOT OK THEN _
  3611.          TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,71) + _
  3612.                              MID$(TRANSFER.OPTIONS$,82) : _
  3613.          WXMODEM.SUPPORT = FALSE
  3614.       XFER.COM.FILE$ = PROTOCOL.PATH$ + "QMXFER.COM"
  3615.       CALL FINDIT (XFER.COM.FILE$)
  3616.       IF NOT OK THEN _
  3617.          TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,42) + _
  3618.                              MID$(TRANSFER.OPTIONS$,72) : _
  3619.          XFER.SUPPORT = FALSE
  3620.       KERMIT.EXE.FILE$ = PROTOCOL.PATH$ + "PCKERMIT.EXE"
  3621.       CALL FINDIT (KERMIT.EXE.FILE$)
  3622.       IF NOT OK THEN _
  3623.          TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,33) + _
  3624.                              MID$(TRANSFER.OPTIONS$,43) : _
  3625.          KERMIT.SUPPORT = FALSE
  3626.       CLOSE 2
  3627.       IF KERMIT.SUPPORT = 0 AND _
  3628.          XFER.SUPPORT = 0 AND _
  3629.          WXMODEM.SUPPORT = 0 THEN _
  3630.          TRANSFER.OPTIONS$ = LEFT$(TRANSFER.OPTIONS$,31) + _
  3631.                              MID$(TRANSFER.OPTIONS$,34)
  3632.       END SUB
  3633. ' $SUBTITLE: 'TRANSFER - subroutine for KERMIT, YMODEM, IMODEM & YMODEM'
  3634. ' $PAGE
  3635. '
  3636. '  SUBROUTINE NAME    -- TRANSFER
  3637. '
  3638. '  INPUT PARAMETERS   --     PARAMETER                    MEANING
  3639. '                        TRANSFER.FUNCTION         = 1 DOWNLOAD FILE TO USER
  3640. '                                                  = 2 UPLOAD FILE TO RBBS-PC
  3641. '                        FILE.NAME$                NAME OF FILE FOR TRANSFER
  3642. '                        COM.PORT$                 NAME OF COMMUNICATIONS PORT
  3643. '                                                  TO BE USED BY KERMIT (COM1
  3644. '                                                  OR COM2)
  3645. '                        BPS                       = -1 FOR   300 BAUD
  3646. '                                                  = -2 FOR   450 BAUD
  3647. '                                                  = -3 FOR  1200 BAUD
  3648. '                                                  = -4 FOR  2400 BAUD
  3649. '                                                  = -5 FOR  4800 BAUD
  3650. '                                                  = -6 FOR  9600 BAUD
  3651. '                        PCKERMIT.EXE.FILE$        FILE TO TRANSFER CONTROL TO
  3652. '                                                  FOR KERMIT PROTOCOL ON
  3653. '                                                  PROTOCOL.PATH$.
  3654. '                        QMXFER.COM.FILE$          FILE TO TRANSFER CONTROL TO
  3655. '                                                  FOR YMODEM, IMODEM OR
  3656. '                                                  YMODEMG PROTOCOLS.
  3657. '                        WXMODEM.COM.FILE$         FILE TO TRANSFER CONTROL TO
  3658. '                                                  FOR WXMODEM PROTOCOL ON
  3659. '                                                  PROTOCOL.PATH$
  3660. '
  3661. '  OUTPUT PARAMETERS  -- NONE
  3662. '
  3663. '  SUBROUTINE PURPOSE -- TO TRANSFER FILES USING KERMIT, YMODEM, IMODEM,
  3664. '                        YMODEMG OR WXMODEM PROTOCOL'S
  3665. '
  3666. 62620 SUB TRANSFER STATIC
  3667.       IF PRIVATE.DOOR THEN _
  3668.          GOTO 62629
  3669.       IF TRANSFER.FUNCTION = 1 THEN _
  3670.          TRANSFER.COMMAND$ = "-s " : _
  3671.          A$ = " send of " _
  3672.       ELSE IF TRANSFER.FUNCTION = 2 THEN _
  3673.               TRANSFER.COMMAND$ = "-r ": _
  3674.               A$ = " receive of " : _
  3675.               IF FF = 4 THEN _
  3676.                  TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _
  3677.                                      "-a "
  3678.       IF FF <> 4 THEN _
  3679.          TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + "-f "
  3680.       TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _
  3681.                           FILE.NAME$ + _
  3682.                           " -l " + COM.PORT$ + _
  3683.                           " -c" + _                 ' CARRIER DROP
  3684.                           " -b " + _                ' LINE SPEED
  3685.                           MID$("    300 4501200240048009600",(-4*BPS),4)
  3686.       IF FF = 4 THEN _
  3687.          TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _
  3688.                              " -p n" + _            ' PARITY = NONE
  3689.                              " -m 31" _             ' PACKETS
  3690.       ELSE TRANSFER.COMMAND$ = TRANSFER.COMMAND$ + _
  3691.                                " -p " + _
  3692.                                MID$("AXCKYIGW",FF,1) + _
  3693.                                " -n " + _
  3694.                                NODE.ID$
  3695.       ON FF GOTO 62628, _     ' 1 = ASCII FILE TRANSFER
  3696.                  62622, _     ' 2 = XMODEM (CHECKSUM) FILE TRANSFER
  3697.                  62622, _     ' 3 = XMODEM (CRC-16) FILE TRANSFER
  3698.                  62624, _     ' 4 = KERMIT FILE TRANSFER
  3699.                  62622, _     ' 5 = YMODEM FILE TRANSFER
  3700.                  62622, _     ' 6 = IMODEM FILE TRANSFER
  3701.                  62622, _     ' 7 = YMODEMG FILE TRANSFER
  3702.                  62626        ' 8 = WXMODEM FILE TRANSFER
  3703. 62622 B$ = "QMXFER"
  3704.       IF FF<4 THEN _
  3705.          Y$ = "XMODEM ":_
  3706.          IF FF=2 THEN _
  3707.             Y$ = Y$ + "(CHECKSUM)"_
  3708.          ELSE_
  3709.             Y$ = Y$ + "(CRC-16)"_
  3710.       ELSE_
  3711.          IF FF=6 THEN_
  3712.             Y$ = "IMODEM"_
  3713.          ELSE_
  3714.             Y$ = "YMODEM":_
  3715.             IF FF=7 THEN _
  3716.                Y$ = Y$ + "G"
  3717.       GOTO 62628
  3718. 62624 B$ = "PCKERMIT"
  3719.       Y$ = "KERMIT"
  3720.       GOTO 62628
  3721. 62626 B$ = "WXMODEM"
  3722.       Y$ = "XMODEM (WINDOWED)"
  3723. 62628 CLOSE 2
  3724.       OPEN NODE.WORK.FILE$ FOR OUTPUT AS #2
  3725.       B$ = PROTOCOL.PATH$ + B$ + " " + TRANSFER.COMMAND$
  3726.       PRINT #2,B$
  3727.       CLOSE 2
  3728.       CALL QTPUT (Y$ + A$ + FILE.NAME.HOLD$ + " ready!",1)
  3729.       IF GO.TO.SHELL THEN _
  3730.          GOTO 62629
  3731.       A$(1) = DISK.FOR.DOS$ + "COMMAND /C " + B$
  3732.       A$(2) = RBBS.BAT$
  3733.       PRIVATE.DOOR = TRUE
  3734.       CALL RBBSEXIT (A$(),2)
  3735. 62629 CLOSE 3
  3736.       OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
  3737.       IF PRIVATE.DOOR THEN _
  3738.          PRIVATE.DOOR = FALSE : _
  3739.          GOTO 62630
  3740.       CALL DELAYIT (2)
  3741.       SHELL NODE.WORK.FILE$
  3742. 62630 OPEN.BAUD$ = MID$("    300 3001200240048009600",(-4*BPS),4)    ' CPC15-1B
  3743.       PARITY$ = MID$(",N,8,1,E,7,1",7 + 6*EIGHT.BIT,6)               ' CPC15-1B
  3744.       IF LOCAL.USER THEN _
  3745.          GOTO 62631
  3746.       CALL OPENCOM(OPEN.BAUD$,PARITY$)                               ' CPC15-1B
  3747.       CALL SKIPLINE (1)
  3748. 62631 IF TRANSFER.FUNCTION = 2 AND _
  3749.          FF = 4 THEN _
  3750.      CLS : _
  3751.          CALL LINE25
  3752. 62632 END SUB
  3753. ' $SUBTITLE: 'VIEWARC - subroutine to display .ARC contents'
  3754. ' $PAGE
  3755. '
  3756. '  SUBROUTINE NAME    --  VIEWARC  (Written by Jon Martin)
  3757. '
  3758. '  INPUT PARAMETERS   --  PARAMETER                   MEANING
  3759. '                         FILE.NAME$           NAME OF THE ARC FILE TO BE
  3760. '                                              VIEWED.
  3761. '
  3762. '  OUTPUT PARAMETERS  --  NONE
  3763. '
  3764. '  SUBROUTINE PURPOSE --  PROVIDES A MECHANISM TO PROVIDE USERS WITH THE
  3765. '                         CONTENTS OF AN ARC FILE PRIOR TO DOWNLOADING.
  3766.       SUB VIEWARC STATIC
  3767. 64600 IF TURBO.RBBS THEN _
  3768.          RETCODE% = 0 : _
  3769.          CALL ARCV (ARC.WORK$,FILE.NAME$,RETCODE%) : _
  3770.          CALL BUFFILE (ARC.WORK$) : _
  3771.          EXIT SUB
  3772.       CLOSE 2
  3773.       OPEN "R",2,FILE.NAME$,1
  3774.       FIELD 2,1 AS CHAR$
  3775.       BYTE.POINTER! = 1
  3776.       ARC.END! = LOF(2)
  3777. 64605 IF BYTE.POINTER! > ARC.END! THEN _
  3778.          GOTO 64620
  3779.       GET 2,BYTE.POINTER!
  3780.       IF CHAR$ <> CHR$(26) THEN _
  3781.          GOTO 64620
  3782.       BYTE.POINTER! = BYTE.POINTER! +1
  3783.       GET 2,BYTE.POINTER!
  3784.       IF CHAR$ = CHR$(0) THEN _
  3785.          GOTO 64620
  3786.       ARCED.NAME$ = ""
  3787.       FOR X = 1 TO 12
  3788.       GET 2,BYTE.POINTER! + X
  3789.       IF CHAR$ < CHR$(40) THEN _
  3790.          GOTO 64610
  3791.       ARCED.NAME$ = ARCED.NAME$ + CHAR$
  3792.       NEXT
  3793. 64610 A$ = ARCED.NAME$
  3794.       BYTE.POINTER! = BYTE.POINTER! + 14
  3795.       GOSUB 64630
  3796.       TOTAL.BYTES# = WORK.BYTES#
  3797.       BYTE.POINTER! = BYTE.POINTER! + 10
  3798.       GOSUB 64630
  3799.       FINAL.BYTES# = WORK.BYTES#
  3800.       A$ = A$ + SPACE$(20-LEN(ARCED.NAME$) - LEN(STR$(FINAL.BYTES#))) _
  3801.               + STR$(FINAL.BYTES#) _
  3802.               + " bytes."
  3803.       CALL QTPUT(A$,1)
  3804.       BYTE.POINTER! = BYTE.POINTER! + TOTAL.BYTES# + 4
  3805.       GOTO 64605
  3806. 64620 CLOSE 2
  3807.       SUBROUTINE.PARAMETER = 0
  3808.       CALL CARRIER
  3809.       A$ = ""
  3810.       EXIT SUB
  3811. 64630 FACTOR# = 1#
  3812.       WORK.BYTES# = 0
  3813.       FOR X = 0 TO 3
  3814.           GET 2,BYTE.POINTER! + X
  3815.           WORK.BYTES# = WORK.BYTES# + FACTOR# * ASC(CHAR$)
  3816.           FACTOR# = FACTOR# * 256#
  3817.       NEXT
  3818.       RETURN
  3819.       END SUB
  3820.